From c116c13e03b61deefd41ad548b019af467e91506 Mon Sep 17 00:00:00 2001
From: Fritz O. Reese <fritzoreese@gmail.com>
Date: Fri, 17 Oct 2014 15:46:05 -0400
Subject: [PATCH] 2016-03-02 Fritz Reese <fritzoreese@gmail.com>
gcc/fortran/
* lang.opt, invoke.texi, options.c: New option -finit-derived.
* gfortran.h (gfc_option): New option -finit-derived.
(gfc_default_initializer): Update prototype.
(gfc_build_default_init_expr, gfc_apply_init): New prototypes.
* expr.c (gfc_build_default_init_expr, gfc_apply_init,
component_initializer): New functions.
(gfc_default_initializer): Allow generation of initializers.
* decl.c (build_struct): Use new function gfc_apply_init.
(variable_decl): Use new interface for gfc_default_initializer.
(gfc_match_derived_decl): Likewise.
* trans-openmp.c (gfc_trans_omp_array_reduction_or_udr): Likewise.
* trans-decl.c (gfc_generate_function_code): Likewise.
* class.c (gfc_find_derived_vtab, find_intrinsic_vtab): Likewise.
* resolve.c (resolve_allocate_expr): Likewise.
(build_default_init_expr): Use new function gfc_build_default_init_expr.
(can_generate_init): New function.
(apply_default_init, resolve_fl_variable_derived): Use
gfc_default_initializer to generate initializers.
gcc/testsuite/gfortran.dg/
* assert.inc: Runtime assertions.
* init_flag_13.f90, init_flag_14.f90: New testcases for -finit-derived.
---
gcc/fortran/class.c | 7 +-
gcc/fortran/decl.c | 50 +-----
gcc/fortran/expr.c | 267 ++++++++++++++++++++++++++--
gcc/fortran/gfortran.h | 6 +-
gcc/fortran/invoke.texi | 9 +-
gcc/fortran/lang.opt | 4 +
gcc/fortran/options.c | 5 +
gcc/fortran/resolve.c | 194 +++++----------------
gcc/fortran/trans-decl.c | 3 +-
gcc/fortran/trans-openmp.c | 2 +-
gcc/testsuite/gfortran.dg/assert.inc | 62 +++++++
gcc/testsuite/gfortran.dg/init_flag_13.f90 | 36 ++++
gcc/testsuite/gfortran.dg/init_flag_14.f90 | 36 ++++
13 files changed, 460 insertions(+), 221 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/assert.inc
create mode 100644 gcc/testsuite/gfortran.dg/init_flag_13.f90
create mode 100644 gcc/testsuite/gfortran.dg/init_flag_14.f90
@@ -2325,7 +2325,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
gfc_set_sym_referenced (def_init);
def_init->ts.type = BT_DERIVED;
def_init->ts.u.derived = derived;
- def_init->value = gfc_default_initializer (&def_init->ts);
+ def_init->value = gfc_default_initializer (&def_init->ts,
+ false);
c->initializer = gfc_lval_expr_from_sym (def_init);
}
@@ -2412,7 +2413,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
have_vtype:
vtab->ts.u.derived = vtype;
- vtab->value = gfc_default_initializer (&vtab->ts);
+ vtab->value = gfc_default_initializer (&vtab->ts, false);
}
}
@@ -2680,7 +2681,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->initializer = gfc_get_null_expr (NULL);
}
vtab->ts.u.derived = vtype;
- vtab->value = gfc_default_initializer (&vtab->ts);
+ vtab->value = gfc_default_initializer (&vtab->ts, false);
}
}
@@ -1710,51 +1710,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 (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)
@@ -2234,7 +2190,7 @@ variable_decl (int elem)
{
if (current_ts.type == BT_DERIVED
&& !current_attr.pointer && !initializer)
- initializer = gfc_default_initializer (¤t_ts);
+ initializer = gfc_default_initializer (¤t_ts, false);
t = build_struct (name, cl, &initializer, &as);
}
@@ -8154,7 +8110,7 @@ gfc_match_derived_decl (void)
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
- p->initializer = gfc_default_initializer (&p->ts);
+ p->initializer = gfc_default_initializer (&p->ts, false);
/* Set extension level. */
if (extended->attr.extension == 255)
@@ -3918,6 +3918,210 @@ 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 (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 +4150,55 @@ 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_component *c, bool generate)
+{
+ gfc_expr *init = NULL;
+
+ if (c->initializer || !generate)
+ return c->initializer;
+
+ /* Recursively handle derived type components. */
+ if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ init = gfc_default_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.
+ If -finit-derived is specified, generate default initialization expressions
+ for components that lack them when generate is set. */
gfc_expr *
-gfc_default_initializer (gfc_typespec *ts)
+gfc_default_initializer (gfc_typespec *ts, bool generate)
{
- gfc_expr *init;
+ gfc_expr *init, *tmp;
gfc_component *comp;
+ generate = gfc_option.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,11 +4211,14 @@ 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 (comp, generate);
+ if (tmp)
{
- 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);
}
@@ -2517,6 +2517,8 @@ typedef struct
int flag_preprocessed;
int flag_d_lines;
+ int flag_init_derived;
+ int flag_init_local_zero;
int flag_init_integer;
int flag_init_integer_value;
int flag_init_logical;
@@ -3025,8 +3027,10 @@ 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_default_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 *);
@@ -179,6 +179,7 @@ and warnings}.
-finit-logical=@var{<true|false>}
-finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
-finline-matmul-limit=@var{n} @gol
+-finit-derived @gol
-fmax-array-constructor=@var{n} -fmax-stack-var-size=@var{n}
-fno-align-commons @gol
-fno-automatic -fno-protect-parens -fno-underscoring @gol
@@ -1568,11 +1569,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}
@@ -1587,13 +1590,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).
@@ -512,6 +512,10 @@ finit-character=
Fortran RejectNegative Joined UInteger
-finit-character=<n> Initialize local character variables to ASCII value n.
+finit-derived
+Fortran
+Initialize components of derived type variables according to other flags
+
finit-integer=
Fortran RejectNegative Joined
-finit-integer=<n> Initialize local integer variables to n.
@@ -83,6 +83,7 @@ gfc_init_options (unsigned int decoded_options_count,
gfc_option.flag_preprocessed = 0;
gfc_option.flag_d_lines = -1;
+ gfc_option.flag_init_derived = 0;
gfc_option.flag_init_integer = GFC_INIT_INTEGER_OFF;
gfc_option.flag_init_integer_value = 0;
gfc_option.flag_init_logical = GFC_INIT_LOGICAL_OFF;
@@ -603,6 +604,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
gfc_option.flag_init_character_value = (char)0;
break;
+ case OPT_finit_derived:
+ gfc_option.flag_init_derived = 1;
+ break;
+
case OPT_finit_logical_:
if (!strcasecmp (arg, "false"))
gfc_option.flag_init_logical = GFC_INIT_LOGICAL_FALSE;
@@ -7125,7 +7125,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
using _copy and trans_call. It is convenient to exploit that
when the allocated type is different from the declared type but
no SOURCE exists by setting expr3. */
- code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts, false);
}
else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
@@ -7148,7 +7148,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
if (ts.type == BT_CLASS)
ts = ts.u.derived->components->ts;
- if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
+ if (ts.type == BT_DERIVED
+ && (init_e = gfc_default_initializer (&ts, false)))
{
gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN);
init_st->loc = code->loc;
@@ -7161,7 +7162,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
{
/* Default initialization via MOLD (non-polymorphic). */
- gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts, false);
if (rhs != NULL)
{
gfc_resolve_expr (rhs);
@@ -11091,6 +11092,36 @@ 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
+ || 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
@@ -11102,7 +11133,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_default_initializer (&sym->ts, can_generate_init (sym));
if (init == NULL && sym->ts.type != BT_CLASS)
return;
@@ -11111,17 +11142,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
@@ -11136,145 +11163,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. */
@@ -11458,7 +11348,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
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_default_initializer (&sym->ts, can_generate_init (sym));
}
return true;
@@ -6187,7 +6187,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_default_initializer (&rsym->ts,
+ true);
if (init_exp)
{
tmp = gfc_trans_structure_assign (result, init_exp, 0);
@@ -1474,7 +1474,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
else if (udr->initializer_ns == NULL)
{
gcc_assert (sym->ts.type == BT_DERIVED);
- e2 = gfc_default_initializer (&sym->ts);
+ e2 = gfc_default_initializer (&sym->ts, false);
gcc_assert (e2);
t = gfc_resolve_expr (e2);
gcc_assert (t);
new file mode 100644
@@ -0,0 +1,62 @@
+
+subroutine assert(s, b)
+ character*(*), intent(in) :: s
+ logical, intent(in) :: b
+ if (.not. b) then
+ print *, s
+ call abort
+ endif
+endsubroutine
+
+subroutine assertss(s, s1, s2)
+ character*(*), intent(in) :: s, s1, s2
+ if (s1 /= s2) then
+ print *, s, ": expected ", s2, " but was ", s1
+ call abort
+ endif
+endsubroutine
+
+subroutine assertbb(s, b1, b2)
+ character*(*), intent(in) :: s
+ integer(1), intent(in) :: b1, b2
+ if (b1 .ne. b2) then
+ print *, s, ": expected ", b2, " but was ", b1
+ call abort
+ endif
+endsubroutine
+
+subroutine assertii(s, i1, i2)
+ character*(*), intent(in) :: s
+ integer(2), intent(in) :: i1, i2
+ if (i1 .ne. i2) then
+ print *, s, ": expected ", i2, " but was ", i1
+ call abort
+ endif
+endsubroutine
+
+subroutine assertll(s, l1, l2)
+ character*(*), intent(in) :: s
+ integer(4), intent(in) :: l1, l2
+ if (l1 .ne. l2) then
+ print *, s, ": expected ", l2, " but was ", l1
+ call abort
+ endif
+endsubroutine
+
+subroutine assertqq(s, q1, q2)
+ character*(*), intent(in) :: s
+ integer(8), intent(in) :: q1, q2
+ if (q1 .ne. q2) then
+ print *, s, ": expected ", q2, " but was ", q1
+ call abort
+ endif
+endsubroutine
+
+subroutine assertrr(s, r1, r2)
+ character*(*), intent(in) :: s
+ real, intent(in) :: r1, r2
+ if (r1 .ne. r2) then
+ print *, s, ": expected ", r1, " but was ", r2
+ call abort
+ endif
+endsubroutine
new file mode 100644
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-finit-local-zero -finit-derived" }
+!
+! Make sure -finit-derived initializes components of local derived type
+! variables to zero with -finit-local-zero.
+!
+include 'assert.inc'
+
+type t2
+ integer i
+ real r
+ character c
+ logical l
+end type
+
+type t1
+ logical l
+ real r
+ character c
+ integer i
+ type (t2) y
+end type
+
+type (t1) :: x
+
+call assertll ("x%i", x%i, 0)
+call assertrr ("x%r", x%r, 0.0)
+call assertss ("x%c", x%c, CHAR(0))
+call assert ("x%l", .not. x%l)
+
+call assertll ("x%y%i", x%y%i, 0)
+call assertrr ("x%y%r", x%y%r, 0.0)
+call assertss ("x%y%c", x%y%c, CHAR(0))
+call assert ("x%y%l", .not. x%y%l)
+
+end
new file mode 100644
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-finit-derived -finit-integer=42 -finit-real=inf -finit-logical=true -finit-character=32 -fno-range-check" }
+!
+! Make sure -finit-derived initializes components of local derived type
+! variables according to other -finit-* flags.
+!
+include 'assert.inc'
+
+type t2
+ integer i
+ real r
+ character c
+ logical l
+end type
+
+type t1
+ logical l
+ real r
+ character c
+ integer i
+ type (t2) y
+end type
+
+type (t1) :: x
+
+call assertll ("x%i", x%i, 42)
+call assertrr ("x%r", x%r, 1./0.)
+call assertss ("x%c", x%c, ' ')
+call assert ("x%l", x%l)
+
+call assertll ("x%y%i", x%y%i, 42)
+call assertrr ("x%y%r", x%y%r, 1./0.)
+call assertss ("x%y%c", x%y%c, ' ')
+call assert ("x%y%l", x%y%l)
+
+end
--
1.7.1