procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/57306 ([OOP] [F08] ICE on valid with class pointer initialization)

Browse source 
2013-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/57306
	* class.c (gfc_class_null_initializer): Rename to
	'gfc_class_initializer'. Treat non-NULL init-exprs.
	* gfortran.h (gfc_class_null_initializer): Update prototype.
	* trans-decl.c (gfc_get_symbol_decl): Treat class variables.
	* trans-expr.c (gfc_conv_initializer): Ditto.
	(gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.

2013-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/57306
	* gfortran.dg/pointer_init_8.f90: New.

From-SVN: r201521
This commit is contained in:
Janus Weil 2013-08-06 10:20:17 +02:00
parent 67d6162ac8
commit 2cc6320da1
7 changed files with 68 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View file

@ -1,3 +1,13 @@
2013-08-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/57306
* class.c (gfc_class_null_initializer): Rename to
'gfc_class_initializer'. Treat non-NULL init-exprs.
* gfortran.h (gfc_class_null_initializer): Update prototype.
* trans-decl.c (gfc_get_symbol_decl): Treat class variables.
* trans-expr.c (gfc_conv_initializer): Ditto.
(gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.
2013-07-30 Tobias Burnus <burnus@net-b.de>
PR fortran/57530

12
gcc/fortran/class.c
View file

@ -412,12 +412,12 @@ gfc_is_class_container_ref (gfc_expr *e)
}
/* Build a NULL initializer for CLASS pointers,
initializing the _data component to NULL and
the _vptr component to the declared type. */
/* Build an initializer for CLASS pointers,
initializing the _data component to the init_expr (or NULL) and the _vptr
component to the corresponding type (or the declared type, given by ts). */
gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{
gfc_expr *init;
gfc_component *comp;
@ -430,6 +430,8 @@ gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
if (is_unlimited_polymorphic && init_expr)
vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
else if (init_expr && init_expr->expr_type != EXPR_NULL)
vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
else
vtab = gfc_find_derived_vtab (ts->u.derived);
@ -442,6 +444,8 @@ gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
gfc_constructor *ctor = gfc_constructor_get();
if (strcmp (comp->name, "_vptr") == 0 && vtab)
ctor->expr = gfc_lval_expr_from_sym (vtab);
else if (init_expr && init_expr->expr_type != EXPR_NULL)
ctor->expr = gfc_copy_expr (init_expr);
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);

2
gcc/fortran/gfortran.h
View file

@ -2983,7 +2983,7 @@ void gfc_add_class_array_ref (gfc_expr *);
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *);
gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);

14
gcc/fortran/trans-decl.c
View file

@ -1491,14 +1491,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
SAVE is specified otherwise they need to be reinitialized
every time the procedure is entered. The TREE_STATIC is
in this case due to -fmax-stack-var-size=. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
TREE_TYPE (decl),
sym->attr.dimension
|| (sym->attr.codimension
&& sym->attr.allocatable),
sym->attr.pointer
|| sym->attr.allocatable,
sym->attr.proc_pointer);
TREE_TYPE (decl), sym->attr.dimension
|| (sym->attr.codimension
&& sym->attr.allocatable),
sym->attr.pointer || sym->attr.allocatable
|| sym->ts.type == BT_CLASS,
sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)

14
gcc/fortran/trans-expr.c
View file

@ -5664,7 +5664,15 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
else if (pointer || procptr)
{
if (!expr || expr->expr_type == EXPR_NULL)
if (ts->type == BT_CLASS && !procptr)
{
gfc_init_se (&se, NULL);
gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
TREE_STATIC (se.expr) = 1;
return se.expr;
}
else if (!expr || expr->expr_type == EXPR_NULL)
return fold_convert (type, null_pointer_node);
else
{
@ -5683,7 +5691,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
case BT_CLASS:
gfc_init_se (&se, NULL);
if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
else
gfc_conv_structure (&se, expr, 1);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
@ -5993,7 +6001,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
gfc_class_null_initializer (&cm->ts, expr));
gfc_class_initializer (&cm->ts, expr));
gfc_add_expr_to_block (&block, tmp);
}
else if (cm->attr.dimension && !cm->attr.proc_pointer)

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2013-08-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/57306
* gfortran.dg/pointer_init_8.f90: New.
2013-08-05 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/58080

26
gcc/testsuite/gfortran.dg/pointer_init_8.f90 Normal file
View file

@ -0,0 +1,26 @@
! { dg-do run }
!
! PR 57306: [OOP] ICE on valid with class pointer initialization
!
! Contributed by Andrew Benson <abensonca@gmail.com>
module m
type :: c
end type c
type, extends(c) :: d
end type d
type(c), target :: x
type(d), target :: y
end module m
use m
class(c), pointer :: px => x
class(c), pointer :: py => y
if (.not. associated(px, x)) call abort()
if (.not. same_type_as(px, x)) call abort()
if (.not. associated(py, y)) call abort()
if (.not. same_type_as(py, y)) call abort()
end
! { dg-final { cleanup-modules "m" } }