From: Fritz Reese Date: Mon, 15 Aug 2016 21:19:09 +0000 (+0000) Subject: lang.opt, [...]: New flag -finit-derived. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7fc61626174d8fa80e2af1ff693b7075da4cf039;p=gcc.git lang.opt, [...]: New flag -finit-derived. 2016-08-15 Fritz Reese 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 84bfb334168..c6d1ff38598 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2016-08-15 Fritz Reese + + 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 * frontend-passes.c (create_var): Set ts.deferred for diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 25b0df7130f..ce5ebb763ba 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 6d0eb22eea5..8e2b892fc24 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 77831ab31e9..813f7d9f10a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 2fd12cb6a1a..15c131ac865 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -178,6 +178,7 @@ and warnings}. -fcoarray=@var{} -fexternal-blas -ff2c -ffrontend-optimize @gol -finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero @gol +-finit-derived @gol -finit-logical=@var{} -finit-real=@var{} @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{} @itemx -finit-logical=@var{} @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{}}, 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). diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 4ff54e2ca8b..8ec5400ec95 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -528,6 +528,10 @@ finit-character= Fortran RejectNegative Joined UInteger -finit-character= 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= Initialize local integer variables to n. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d8cfdd275b6..7763f9c7345 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 25b846e7b85..6cf7f573bf6 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4b4c9ca2a1c..810aca1a4a8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2016-08-15 Fritz Reese + + * 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 PR target/72867 diff --git a/gcc/testsuite/gfortran.dg/dec_init_1.f90 b/gcc/testsuite/gfortran.dg/dec_init_1.f90 new file mode 100644 index 00000000000..91f16f85294 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_init_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dec_init_2.f90 b/gcc/testsuite/gfortran.dg/dec_init_2.f90 new file mode 100644 index 00000000000..0efcdf96ad1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_init_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/init_flag_13.f90 b/gcc/testsuite/gfortran.dg/init_flag_13.f90 new file mode 100644 index 00000000000..cdd039af78c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/init_flag_13.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/init_flag_14.f90 b/gcc/testsuite/gfortran.dg/init_flag_14.f90 new file mode 100644 index 00000000000..13991f826d7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/init_flag_14.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/init_flag_15.f03 b/gcc/testsuite/gfortran.dg/init_flag_15.f03 new file mode 100644 index 00000000000..fef9442dd50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/init_flag_15.f03 @@ -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