OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

lang.opt, [...]: New flag -finit-derived. 

2016-08-15  Fritz Reese  <fritzoreese@gmail.com>

	gcc/fortran/
	* lang.opt, invoke.texi: New flag -finit-derived.
	* gfortran.h (gfc_build_default_init_expr, gfc_apply_init,
	gfc_generate_initializer): New prototypes.
	* expr.c (gfc_build_default_init_expr, gfc_apply_init,
	component_initializer, gfc_generate_initializer): New functions.
	* expr.c (gfc_default_initializer): Wrap gfc_generate_initializer.
	* decl.c (build_struct): Move common code to gfc_apply_init.
	* resolve.c (can_generate_init): New function.
	* resolve.c (build_default_init_expr): Wrap gfc_build_default_init_expr.
	* resolve.c (apply_default_init, resolve_fl_variable_derived): Use
	gfc_generate_initializer.
	* trans-decl.c (gfc_generate_function_code): Use
	gfc_generate_initializer.

	gcc/testsuite/gfortran.dg/
	* init_flag_13.f90: New testcase.
	* init_flag_14.f90: Ditto.
	* init_flag_15.f03: Ditto.
	* dec_init_1.f90: Ditto.
	* dec_init_2.f90: Ditto.

From-SVN: r239489
This commit is contained in:
Fritz Reese 2016-08-15 21:19:09 +00:00 committed by Fritz Reese
parent 874be74ab3
commit 7fc6162617
14 changed files with 623 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View File

@ -1,3 +1,20 @@
2016-08-15 Fritz Reese <fritzoreese@gmail.com>
gcc/fortran/
* lang.opt, invoke.texi: New flag -finit-derived.
* gfortran.h (gfc_build_default_init_expr, gfc_apply_init,
gfc_generate_initializer): New prototypes.
* expr.c (gfc_build_default_init_expr, gfc_apply_init,
component_initializer, gfc_generate_initializer): New functions.
* expr.c (gfc_default_initializer): Wrap gfc_generate_initializer.
* decl.c (build_struct): Move common code to gfc_apply_init.
* resolve.c (can_generate_init): New function.
* resolve.c (build_default_init_expr): Wrap gfc_build_default_init_expr.
* resolve.c (apply_default_init, resolve_fl_variable_derived): Use
gfc_generate_initializer.
* trans-decl.c (gfc_generate_function_code): Use
gfc_generate_initializer.
2016-08-15 Thomas Koenig <tkoenig@gcc.gnu.org>
* frontend-passes.c (create_var): Set ts.deferred for

48
gcc/fortran/decl.c
View File

@ -1910,53 +1910,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
}
*as = NULL;
/* Should this ever get more complicated, combine with similar section
in add_init_expr_to_sym into a separate function. */
if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer
&& c->ts.u.cl
&& c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len;
gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
len = mpz_get_si (c->ts.u.cl->length->value.integer);
if (c->initializer->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, c->initializer, -1);
else if (c->initializer
&& c->initializer->ts.u.cl
&& mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
gfc_constructor *ctor;
ctor = gfc_constructor_first (c->initializer->value.constructor);
if (ctor)
{
int first_len;
bool has_ts = (c->initializer->ts.u.cl
&& c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
length. This need not be the length of the LHS! */
gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
for ( ; ctor; ctor = gfc_constructor_next (ctor))
if (ctor->expr->expr_type == EXPR_CONSTANT)
{
gfc_set_constant_character_len (len, ctor->expr,
has_ts ? -1 : first_len);
ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
}
}
}
}
gfc_apply_init (&c->ts, &c->attr, c->initializer);
/* Check array components. */
if (!c->attr.dimension)

279
gcc/fortran/expr.c
View File

@ -3918,6 +3918,212 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
}
/* Build an initializer for a local integer, real, complex, logical, or
character variable, based on the command line flags finit-local-zero,
finit-integer=, finit-real=, finit-logical=, and finit-character=. */
gfc_expr *
gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
{
int char_len;
gfc_expr *init_expr;
int i;
/* Try to build an initializer expression. */
init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
/* We will only initialize integers, reals, complex, logicals, and
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
switch (ts->type)
{
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
break;
case BT_REAL:
switch (flag_init_real)
{
case GFC_INIT_REAL_SNAN:
init_expr->is_snan = 1;
/* Fall through. */
case GFC_INIT_REAL_NAN:
mpfr_set_nan (init_expr->value.real);
break;
case GFC_INIT_REAL_INF:
mpfr_set_inf (init_expr->value.real, 1);
break;
case GFC_INIT_REAL_NEG_INF:
mpfr_set_inf (init_expr->value.real, -1);
break;
case GFC_INIT_REAL_ZERO:
mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
break;
}
break;
case BT_COMPLEX:
switch (flag_init_real)
{
case GFC_INIT_REAL_SNAN:
init_expr->is_snan = 1;
/* Fall through. */
case GFC_INIT_REAL_NAN:
mpfr_set_nan (mpc_realref (init_expr->value.complex));
mpfr_set_nan (mpc_imagref (init_expr->value.complex));
break;
case GFC_INIT_REAL_INF:
mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
break;
case GFC_INIT_REAL_NEG_INF:
mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
break;
case GFC_INIT_REAL_ZERO:
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
break;
}
break;
case BT_LOGICAL:
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
init_expr->value.logical = 0;
else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
init_expr->value.logical = 1;
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
break;
case BT_CHARACTER:
/* For characters, the length must be constant in order to
create a default initializer. */
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
{
char_len = mpz_get_si (ts->u.cl->length->value.integer);
init_expr->value.character.length = char_len;
init_expr->value.character.string = gfc_get_wide_string (char_len+1);
for (i = 0; i < char_len; i++)
init_expr->value.character.string[i]
= (unsigned char) gfc_option.flag_init_character_value;
}
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& ts->u.cl->length && flag_max_stack_var_size != 0)
{
gfc_actual_arglist *arg;
init_expr = gfc_get_expr ();
init_expr->where = *where;
init_expr->ts = *ts;
init_expr->expr_type = EXPR_FUNCTION;
init_expr->value.function.isym =
gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
init_expr->value.function.name = "repeat";
arg = gfc_get_actual_arglist ();
arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
arg->expr->value.character.string[0] =
gfc_option.flag_init_character_value;
arg->next = gfc_get_actual_arglist ();
arg->next->expr = gfc_copy_expr (ts->u.cl->length);
init_expr->value.function.actual = arg;
}
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
}
return init_expr;
}
/* Apply an initialization expression to a typespec. Can be used for symbols or
components. Similar to add_init_expr_to_sym in decl.c; could probably be
combined with some effort. */
void
gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
{
if (ts->type == BT_CHARACTER && !attr->pointer && init
&& ts->u.cl
&& ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
{
int len;
gcc_assert (ts->u.cl && ts->u.cl->length);
gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER);
len = mpz_get_si (ts->u.cl->length->value.integer);
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init
&& init->ts.u.cl
&& mpz_cmp (ts->u.cl->length->value.integer,
init->ts.u.cl->length->value.integer))
{
gfc_constructor *ctor;
ctor = gfc_constructor_first (init->value.constructor);
if (ctor)
{
int first_len;
bool has_ts = (init->ts.u.cl
&& init->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
length. This need not be the length of the LHS! */
gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
for ( ; ctor; ctor = gfc_constructor_next (ctor))
if (ctor->expr->expr_type == EXPR_CONSTANT)
{
gfc_set_constant_character_len (len, ctor->expr,
has_ts ? -1 : first_len);
ctor->expr->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
}
}
}
}
}
/* Check for default initializer; sym->value is not enough
as it is also set for EXPR_NULL of allocatables. */
@ -3946,21 +4152,66 @@ gfc_has_default_initializer (gfc_symbol *der)
}
/* Get an expression for a default initializer. */
/* Fetch or generate an initializer for the given component.
Only generate an initializer if generate is true. */
static gfc_expr *
component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
{
gfc_expr *init = NULL;
/* See if we can find the initializer immediately. */
if (c->initializer || !generate
|| (ts->type == BT_CLASS && !c->attr.allocatable))
return c->initializer;
/* Recursively handle derived type components. */
if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
init = gfc_generate_initializer (&c->ts, true);
/* Treat simple components like locals. */
else
{
init = gfc_build_default_init_expr (&c->ts, &c->loc);
gfc_apply_init (&c->ts, &c->attr, init);
}
return init;
}
/* Get an expression for a default initializer of a derived type. */
gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
gfc_expr *init;
return gfc_generate_initializer (ts, false);
}
/* Get or generate an expression for a default initializer of a derived type.
If -finit-derived is specified, generate default initialization expressions
for components that lack them when generate is set. */
gfc_expr *
gfc_generate_initializer (gfc_typespec *ts, bool generate)
{
gfc_expr *init, *tmp;
gfc_component *comp;
generate = flag_init_derived && generate;
/* See if we have a default initializer in this, but not in nested
types (otherwise we could use gfc_has_default_initializer()). */
for (comp = ts->u.derived->components; comp; comp = comp->next)
if (comp->initializer || comp->attr.allocatable
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
&& CLASS_DATA (comp)->attr.allocatable))
break;
types (otherwise we could use gfc_has_default_initializer()).
We don't need to check if we are going to generate them. */
comp = ts->u.derived->components;
if (!generate)
{
for (; comp; comp = comp->next)
if (comp->initializer || comp->attr.allocatable
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
&& CLASS_DATA (comp)->attr.allocatable))
break;
}
if (!comp)
return NULL;
@ -3973,15 +4224,19 @@ gfc_default_initializer (gfc_typespec *ts)
{
gfc_constructor *ctor = gfc_constructor_get();
if (comp->initializer)
/* Fetch or generate an initializer for the component. */
tmp = component_initializer (ts, comp, generate);
if (tmp)
{
/* Save the component ref for STRUCTUREs and UNIONs. */
if (ts->u.derived->attr.flavor == FL_STRUCT
|| ts->u.derived->attr.flavor == FL_UNION)
ctor->n.component = comp;
ctor->expr = gfc_copy_expr (comp->initializer);
if ((comp->ts.type != comp->initializer->ts.type
|| comp->ts.kind != comp->initializer->ts.kind)
/* If the initializer was not generated, we need a copy. */
ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
if ((comp->ts.type != tmp->ts.type
|| comp->ts.kind != tmp->ts.kind)
&& !comp->attr.pointer && !comp->attr.proc_pointer)
gfc_convert_type_warn (ctor->expr, &comp->ts, 2, false);
}

3
gcc/fortran/gfortran.h
View File

@ -3041,8 +3041,11 @@ bool gfc_check_assign (gfc_expr *, gfc_expr *, int);
bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
gfc_expr *gfc_build_default_init_expr (gfc_typespec *, locus *);
void gfc_apply_init (gfc_typespec *, symbol_attribute *, gfc_expr *);
bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_generate_initializer (gfc_typespec *, bool);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *);
gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);

9
gcc/fortran/invoke.texi
View File

@ -178,6 +178,7 @@ and warnings}.
-fcoarray=@var{<none|single|lib>} -fexternal-blas -ff2c
-ffrontend-optimize @gol
-finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero @gol
-finit-derived @gol
-finit-logical=@var{<true|false>}
-finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
-finline-matmul-limit=@var{n} @gol
@ -1610,11 +1611,13 @@ on the stack. This flag cannot be used together with
@option{-fmax-stack-var-size=} or @option{-fno-automatic}.
@item -finit-local-zero
@itemx -finit-derived
@itemx -finit-integer=@var{n}
@itemx -finit-real=@var{<zero|inf|-inf|nan|snan>}
@itemx -finit-logical=@var{<true|false>}
@itemx -finit-character=@var{n}
@opindex @code{finit-local-zero}
@opindex @code{finit-derived}
@opindex @code{finit-integer}
@opindex @code{finit-real}
@opindex @code{finit-logical}
@ -1629,13 +1632,13 @@ initialization options are provided by the
the real and imaginary parts of local @code{COMPLEX} variables),
@option{-finit-logical=@var{<true|false>}}, and
@option{-finit-character=@var{n}} (where @var{n} is an ASCII character
value) options. These options do not initialize
value) options. Components of derived type variables will be initialized
according to these flags only with @option{-finit-derived}. These options do
not initialize
@itemize @bullet
@item
allocatable arrays
@item
components of derived type variables
@item
variables that appear in an @code{EQUIVALENCE} statement.
@end itemize
(These limitations may be removed in future releases).

4
gcc/fortran/lang.opt
View File

@ -528,6 +528,10 @@ finit-character=
Fortran RejectNegative Joined UInteger
-finit-character=<n> Initialize local character variables to ASCII value n.
finit-derived
Fortran Var(flag_init_derived)
Initialize components of derived type variables according to other init flags.
finit-integer=
Fortran RejectNegative Joined
-finit-integer=<n> Initialize local integer variables to n.

192
gcc/fortran/resolve.c
View File

@ -11138,6 +11138,39 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
init_st->expr2 = init;
}
/* Whether or not we can generate a default initializer for a symbol. */
static bool
can_generate_init (gfc_symbol *sym)
{
symbol_attribute *a;
if (!sym)
return false;
a = &sym->attr;
/* These symbols should never have a default initialization. */
return !(
a->allocatable
|| a->external
|| a->pointer
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& (CLASS_DATA (sym)->attr.class_pointer
|| CLASS_DATA (sym)->attr.proc_pointer))
|| a->in_equivalence
|| a->in_common
|| a->data
|| sym->module
|| a->cray_pointee
|| a->cray_pointer
|| sym->assoc
|| (!a->referenced && !a->result)
|| (a->dummy && a->intent != INTENT_OUT)
|| (a->function && sym != sym->result)
);
}
/* Assign the default initializer to a derived type variable or result. */
static void
@ -11149,7 +11182,7 @@ apply_default_init (gfc_symbol *sym)
return;
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
init = gfc_default_initializer (&sym->ts);
init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
if (init == NULL && sym->ts.type != BT_CLASS)
return;
@ -11158,17 +11191,13 @@ apply_default_init (gfc_symbol *sym)
sym->attr.referenced = 1;
}
/* Build an initializer for a local integer, real, complex, logical, or
character variable, based on the command line flags finit-local-zero,
finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
null if the symbol should not have a default initialization. */
/* Build an initializer for a local. Returns null if the symbol should not have
a default initialization. */
static gfc_expr *
build_default_init_expr (gfc_symbol *sym)
{
int char_len;
gfc_expr *init_expr;
int i;
/* These symbols should never have a default initialization. */
if (sym->attr.allocatable
|| sym->attr.external
@ -11183,145 +11212,8 @@ build_default_init_expr (gfc_symbol *sym)
|| sym->assoc)
return NULL;
/* Now we'll try to build an initializer expression. */
init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
&sym->declared_at);
/* We will only initialize integers, reals, complex, logicals, and
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
switch (sym->ts.type)
{
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
break;
case BT_REAL:
switch (flag_init_real)
{
case GFC_INIT_REAL_SNAN:
init_expr->is_snan = 1;
/* Fall through. */
case GFC_INIT_REAL_NAN:
mpfr_set_nan (init_expr->value.real);
break;
case GFC_INIT_REAL_INF:
mpfr_set_inf (init_expr->value.real, 1);
break;
case GFC_INIT_REAL_NEG_INF:
mpfr_set_inf (init_expr->value.real, -1);
break;
case GFC_INIT_REAL_ZERO:
mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
break;
}
break;
case BT_COMPLEX:
switch (flag_init_real)
{
case GFC_INIT_REAL_SNAN:
init_expr->is_snan = 1;
/* Fall through. */
case GFC_INIT_REAL_NAN:
mpfr_set_nan (mpc_realref (init_expr->value.complex));
mpfr_set_nan (mpc_imagref (init_expr->value.complex));
break;
case GFC_INIT_REAL_INF:
mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
break;
case GFC_INIT_REAL_NEG_INF:
mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
break;
case GFC_INIT_REAL_ZERO:
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
break;
}
break;
case BT_LOGICAL:
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
init_expr->value.logical = 0;
else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
init_expr->value.logical = 1;
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
break;
case BT_CHARACTER:
/* For characters, the length must be constant in order to
create a default initializer. */
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
init_expr->value.character.length = char_len;
init_expr->value.character.string = gfc_get_wide_string (char_len+1);
for (i = 0; i < char_len; i++)
init_expr->value.character.string[i]
= (unsigned char) gfc_option.flag_init_character_value;
}
else
{
gfc_free_expr (init_expr);
init_expr = NULL;
}
if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& sym->ts.u.cl->length && flag_max_stack_var_size != 0)
{
gfc_actual_arglist *arg;
init_expr = gfc_get_expr ();
init_expr->where = sym->declared_at;
init_expr->ts = sym->ts;
init_expr->expr_type = EXPR_FUNCTION;
init_expr->value.function.isym =
gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
init_expr->value.function.name = "repeat";
arg = gfc_get_actual_arglist ();
arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
NULL, 1);
arg->expr->value.character.string[0]
= gfc_option.flag_init_character_value;
arg->next = gfc_get_actual_arglist ();
arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
init_expr->value.function.actual = arg;
}
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
}
return init_expr;
/* Get the appropriate init expression. */
return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
}
/* Add an initialization expression to a local variable. */
@ -11504,9 +11396,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
{
sym->value = gfc_default_initializer (&sym->ts);
}
sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
return true;
}

3
gcc/fortran/trans-decl.c
View File

@ -6256,7 +6256,8 @@ gfc_generate_function_code (gfc_namespace * ns)
/* Arrays are not initialized using the default initializer of
their elements. Therefore only check if a default
initializer is available when the result is scalar. */
init_exp = rsym->as ? NULL : gfc_default_initializer (&rsym->ts);
init_exp = rsym->as ? NULL
: gfc_generate_initializer (&rsym->ts, true);
if (init_exp)
{
tmp = gfc_trans_structure_assign (result, init_exp, 0);

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2016-08-15 Fritz Reese <fritzoreese@gmail.com>
* gfortran.dg/init_flag_13.f90: New testcase.
* gfortran.dg/init_flag_14.f90: Ditto.
* gfortran.dg/init_flag_15.f03: Ditto.
* gfortran.dg/dec_init_1.f90: Ditto.
* gfortran.dg/dec_init_2.f90: Ditto.
2016-08-15 Uros Bizjak <ubizjak@gmail.com>
PR target/72867

62
gcc/testsuite/gfortran.dg/dec_init_1.f90 Normal file
View File

@ -0,0 +1,62 @@
! { dg-do run }
! { dg-options "-fdec-structure -finit-derived -finit-local-zero -fdump-tree-original" }
!
! Test -finit-derived with DEC structure and union.
!
subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2)
implicit none
integer, intent(in) :: i1
real, intent(in) :: r1
character, intent(in) :: c1
logical, intent(in) :: l1
integer, intent(inout) :: i2
real, intent(inout) :: r2
character, intent(inout) :: c2
logical, intent(inout) :: l2
print *, i1, i2, l1, l2, c1, c2, r1, r2
if ( i1 .ne. 0 .or. i2 .ne. 0 ) call abort()
if ( l1 .or. l2 ) call abort()
if ( c1 .ne. achar(0) .or. c2 .ne. achar(0) ) call abort()
if ( r1 .ne. 0.0 .or. r2 .ne. 0.0 ) call abort()
end subroutine
structure /s3/
union
map
integer m11
real m12
character m13
logical m14
end map
map
logical m21
character m22
real m23
integer m24
end map
end union
end structure
structure /s2/
integer i2
real r2
character c2
logical l2
end structure
structure /s1/
logical l1
real r1
character c1
integer i1
record /s2/ y
end structure
record /s1/ x
record /s3/ y
call dummy (x.i1, x.r1, x.c1, x.l1, x.y.i2, x.y.r2, x.y.c2, x.y.l2)
call dummy (y.m11, y.m12, y.m13, y.m14, y.m24, y.m23, y.m22, y.m21)
end

46
gcc/testsuite/gfortran.dg/dec_init_2.f90 Normal file
View File

@ -0,0 +1,46 @@
! { dg-do run }
! { dg-options "-fdec-structure -finit-derived -finit-integer=42 -finit-real=nan -finit-logical=true -finit-character=32 -fdump-tree-original" }
!
! Test -finit-derived with DEC structure and union.
!
subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2)
implicit none
integer, intent(in) :: i1
real, intent(in) :: r1
character, intent(in) :: c1
logical, intent(in) :: l1
integer, intent(inout) :: i2
real, intent(inout) :: r2
character, intent(inout) :: c2
logical, intent(inout) :: l2
print *, i1, i2, l1, l2, c1, c2, r1, r2
if ( i1 .ne. 42 .or. i2 .ne. 42 ) call abort()
if ( (.not. l1) .or. (.not. l2) ) call abort()
if ( c1 .ne. achar(32) .or. c2 .ne. achar(32) ) call abort()
if ( (.not. isnan(r1)) .or. (.not. isnan(r2)) ) call abort()
end subroutine
! Nb. the current implementation decides the -finit-* flags are meaningless
! with components of a union, so we omit the union test here.
structure /s2/
integer i2
real r2
character c2
logical l2
end structure
structure /s1/
logical l1
real r1
character c1
integer i1
record /s2/ y
end structure
record /s1/ x
call dummy (x.i1, x.r1, x.c1, x.l1, x.y.i2, x.y.r2, x.y.c2, x.y.l2)
end

51
gcc/testsuite/gfortran.dg/init_flag_13.f90 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do compile }
! { dg-options "-finit-local-zero -finit-derived -fdump-tree-original" }
!
! Make sure -finit-derived initializes components of local derived type
! variables to zero with -finit-local-zero.
!
subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2)
implicit none
integer, intent(in) :: i1
real, intent(in) :: r1
character, intent(in) :: c1
logical, intent(in) :: l1
integer, intent(out) :: i2
real, intent(out) :: r2
character, intent(out) :: c2
logical, intent(out) :: l2
end subroutine
type t2
integer i2
real r2
character c2
logical l2
end type
type t1
logical l1
real r1
character c1
integer i1
type (t2) y
end type
type (t1) :: x
call dummy (x%i1, x%r1, x%c1, x%l1, x%y%i2, x%y%r2, x%y%c2, x%y%l2)
end
! We expect to see each component initialized exactly once in MAIN.
! NB. the "once" qualifier also tests that the dummy variables aren't
! given an extraneous initializer.
! { dg-final { scan-tree-dump-times "i1= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "r1= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "c1= *\"\"" 1 "original" } }
! { dg-final { scan-tree-dump-times "l1= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "i2= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "r2= *0" 1 "original" } }
! { dg-final { scan-tree-dump-times "c2= *\"\"" 1 "original" } }
! { dg-final { scan-tree-dump-times "l2= *0" 1 "original" } }

51
gcc/testsuite/gfortran.dg/init_flag_14.f90 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do compile }
! { dg-options "-finit-derived -finit-integer=42 -finit-real=inf -finit-logical=true -finit-character=32 -fdump-tree-original" }
!
! Make sure -finit-derived initializes components of local derived type
! variables according to other -finit-* flags.
!
subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2)
implicit none
integer, intent(in) :: i1
real, intent(in) :: r1
character, intent(in) :: c1
logical, intent(in) :: l1
integer, intent(out) :: i2
real, intent(out) :: r2
character, intent(out) :: c2
logical, intent(out) :: l2
end subroutine
type t2
integer i2
real r2
character c2
logical l2
end type
type t1
logical l1
real r1
character c1
integer i1
type (t2) y
end type
type (t1) :: x
call dummy (x%i1, x%r1, x%c1, x%l1, x%y%i2, x%y%r2, x%y%c2, x%y%l2)
end
! We expect to see each component initialized exactly once in MAIN.
! NB. the "once" qualifier also tests that the dummy variables aren't
! given an extraneous initializer.
! { dg-final { scan-tree-dump-times "i1= *42" 1 "original" } }
! { dg-final { scan-tree-dump-times "r1= *\[iI]nf" 1 "original" } }
! { dg-final { scan-tree-dump-times "c1= *\" \"" 1 "original" } }
! { dg-final { scan-tree-dump-times "l1= *1" 1 "original" } }
! { dg-final { scan-tree-dump-times "i2= *42" 1 "original" } }
! { dg-final { scan-tree-dump-times "r2= *\[iI]nf" 1 "original" } }
! { dg-final { scan-tree-dump-times "c2= *\" \"" 1 "original" } }
! { dg-final { scan-tree-dump-times "l2= *1" 1 "original" } }

64
gcc/testsuite/gfortran.dg/init_flag_15.f03 Normal file
View File

@ -0,0 +1,64 @@
! { dg-do run }
! { dg-options "-finit-derived -finit-integer=1" }
!
! Make sure -finit-derived works on class variables.
! Based on class_result_1.f03
!
module points_2i
implicit none
type point2i
integer :: x, y
end type
contains
subroutine print( point )
class(point2i) :: point
write(*,'(2i4)') point%x, point%y
end subroutine
subroutine set_vector( point, rx, ry )
class(point2i) :: point
integer :: rx, ry
point%x = rx
point%y = ry
end subroutine
function add_vector( point, vector )
class(point2i), intent(in) :: point, vector
class(point2i), allocatable :: add_vector
allocate( add_vector )
add_vector%x = point%x + vector%x
add_vector%y = point%y + vector%y
end function
end module
program init_flag_15
use points_2i
implicit none
type(point2i), target :: point_2i, vector_2i
class(point2i), pointer :: point, vector
type(point2i) :: vsum
integer :: i
point => point_2i ! = (1, 1) due to -finit-integer
vector => vector_2i
call set_vector(vector, 2, 2)
vsum = add_vector(point, vector)
call print(point)
call print(vector)
call print(vsum)
if (vsum%x .ne. 3 .or. vsum%y .ne. 3) then
call abort()
endif
end program