+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
}
*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)
}
+/* 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. */
}
-/* 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;
{
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);
}
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 *);
-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
@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}
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).
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.
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
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;
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
|| 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. */
/* 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;
}
/* 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);
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
projects / gcc.git / commitdiff