/* Routines for manipulation of expression nodes.
- Copyright (C) 2000-2015 Free Software Foundation, Inc.
+ Copyright (C) 2000-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "flags.h"
+#include "options.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
case BT_HOLLERITH:
case BT_LOGICAL:
- case BT_DERIVED:
+ case_bt_struct:
case BT_CLASS:
case BT_ASSUMED:
break; /* Already done. */
p = gfc_get_expr ();
p->expr_type = EXPR_FUNCTION;
p->symtree = NULL;
- p->value.function.actual = NULL;
-
p->value.function.actual = gfc_get_actual_arglist ();
p->value.function.actual->expr = e;
}
-/* Function to determine if an expression is constant or not. This
- function expects that the expression has already been simplified. */
+/* Determine if an expression is constant in the sense of F08:7.1.12.
+ * This function expects that the expression has already been simplified. */
-int
+bool
gfc_is_constant_expr (gfc_expr *e)
{
gfc_constructor *c;
gfc_actual_arglist *arg;
- gfc_symbol *sym;
if (e == NULL)
- return 1;
+ return true;
switch (e->expr_type)
{
|| gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
- return 0;
+ return false;
case EXPR_FUNCTION:
case EXPR_PPC:
{
for (arg = e->value.function.actual; arg; arg = arg->next)
if (!gfc_is_constant_expr (arg->expr))
- return 0;
+ return false;
}
- /* Specification functions are constant. */
- /* F95, 7.1.6.2; F2003, 7.1.7 */
- sym = NULL;
- if (e->symtree)
- sym = e->symtree->n.sym;
- if (e->value.function.esym)
- sym = e->value.function.esym;
-
- if (sym
- && sym->attr.function
- && sym->attr.pure
- && !sym->attr.intrinsic
- && !sym->attr.recursive
- && sym->attr.proc != PROC_INTERNAL
- && sym->attr.proc != PROC_ST_FUNCTION
- && sym->attr.proc != PROC_UNKNOWN
- && gfc_sym_get_dummy_args (sym) == NULL)
- return 1;
-
if (e->value.function.isym
&& (e->value.function.isym->elemental
|| e->value.function.isym->pure
|| e->value.function.isym->inquiry
|| e->value.function.isym->transformational))
- return 1;
+ return true;
- return 0;
+ return false;
case EXPR_CONSTANT:
case EXPR_NULL:
- return 1;
+ return true;
case EXPR_SUBSTRING:
return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
for (; c; c = gfc_constructor_next (c))
if (!gfc_is_constant_expr (c->expr))
- return 0;
+ return false;
- return 1;
+ return true;
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
- return 0;
+ return false;
}
}
/* For extended types, check if the desired component is in one of the
* parent types. */
while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
- pick->name, true, true))
+ pick->name, true, true, NULL))
{
dt = dt->components->ts.u.derived;
c = gfc_constructor_first (c->expr->value.constructor);
case AR_FULL:
if (p->ref->next != NULL
- && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
+ && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
{
for (c = gfc_constructor_first (p->value.constructor);
c; c = gfc_constructor_next (c))
return false;
}
- if (p->ts.type == BT_DERIVED
+ if (gfc_bt_struct (p->ts.type)
&& p->ref->next
&& (c = gfc_constructor_first (p->value.constructor)))
{
gfc_constructor *ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
- gcc_assert (e->ts.type == BT_DERIVED);
+ gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
for (comp = e->ts.u.derived->components,
ctor = gfc_constructor_first (e->value.constructor);
t = false;
{
- gfc_intrinsic_sym* isym;
+ bool conversion;
+ gfc_intrinsic_sym* isym = NULL;
gfc_symbol* sym = e->symtree->n.sym;
- /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
- module IEEE_ARITHMETIC, which is allowed in initialization
- expressions. */
- if (!strcmp(sym->name, "ieee_selected_real_kind")
- && sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
+ IEEE_EXCEPTIONS modules. */
+ int mod = sym->from_intmod;
+ if (mod == INTMOD_NONE && sym->generic)
+ mod = sym->generic->sym->from_intmod;
+ if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
{
- gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e);
+ gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
if (new_expr)
{
gfc_replace_expr (e, new_expr);
}
}
- if (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ /* If a conversion function, e.g., __convert_i8_i4, was inserted
+ into an array constructor, we need to skip the error check here.
+ Conversion errors are caught below in scalarize_intrinsic_call. */
+ conversion = e->value.function.isym
+ && (e->value.function.isym->conversion == 1);
+
+ if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
+ || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES))
{
gfc_error ("Function %qs in initialization expression at %L "
"must be an intrinsic function",
array argument. */
isym = gfc_find_function (e->symtree->n.sym->name);
if (isym && isym->elemental
- && (t = scalarize_intrinsic_call(e)))
+ && (t = scalarize_intrinsic_call (e)))
break;
}
break;
case EXPR_SUBSTRING:
- t = gfc_check_init_expr (e->ref->u.ss.start);
- if (!t)
- break;
-
- t = gfc_check_init_expr (e->ref->u.ss.end);
- if (t)
- t = gfc_simplify_expr (e, 0);
+ if (e->ref)
+ {
+ t = gfc_check_init_expr (e->ref->u.ss.start);
+ if (!t)
+ break;
+ t = gfc_check_init_expr (e->ref->u.ss.end);
+ if (t)
+ t = gfc_simplify_expr (e, 0);
+ }
+ else
+ t = false;
break;
case EXPR_STRUCTURE:
/************* Restricted/specification expressions *************/
-/* Make sure a non-intrinsic function is a specification function. */
+/* Make sure a non-intrinsic function is a specification function,
+ * see F08:7.1.11.5. */
static bool
external_spec_function (gfc_expr *e)
f = e->value.function.esym;
+ /* IEEE functions allowed are "a reference to a transformational function
+ from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
+ "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
+ IEEE_EXCEPTIONS". */
+ if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
+ || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
+ {
+ if (!strcmp (f->name, "ieee_selected_real_kind")
+ || !strcmp (f->name, "ieee_support_rounding")
+ || !strcmp (f->name, "ieee_support_flag")
+ || !strcmp (f->name, "ieee_support_halting")
+ || !strcmp (f->name, "ieee_support_datatype")
+ || !strcmp (f->name, "ieee_support_denormal")
+ || !strcmp (f->name, "ieee_support_divide")
+ || !strcmp (f->name, "ieee_support_inf")
+ || !strcmp (f->name, "ieee_support_io")
+ || !strcmp (f->name, "ieee_support_nan")
+ || !strcmp (f->name, "ieee_support_sqrt")
+ || !strcmp (f->name, "ieee_support_standard")
+ || !strcmp (f->name, "ieee_support_underflow_control"))
+ goto function_allowed;
+ }
+
if (f->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Specification function %qs at %L cannot be a statement "
return false;
}
- if (f->attr.recursive)
- {
- gfc_error ("Specification function %qs at %L cannot be RECURSIVE",
- f->name, &e->where);
+ /* F08:7.1.11.6. */
+ if (f->attr.recursive
+ && !gfc_notify_std (GFC_STD_F2003,
+ "Specification function '%s' "
+ "at %L cannot be RECURSIVE", f->name, &e->where))
return false;
- }
+function_allowed:
return restricted_args (e->value.function.actual);
}
/* Given an assignable expression and an arbitrary expression, make
- sure that the assignment can take place. */
+ sure that the assignment can take place. Only add a call to the intrinsic
+ conversion routines, when allow_convert is set. When this assign is a
+ coarray call, then the convert is done by the coarray routine implictly and
+ adding the intrinsic conversion would do harm in most cases. */
bool
-gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
+ bool allow_convert)
{
gfc_symbol *sym;
gfc_ref *ref;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
- "initialize non-integer variable %qs",
+ "initialize non-integer variable %qs",
&rvalue->where, lvalue->symtree->n.sym->name))
return false;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
}
}
- /* Warn about type-changing conversions for REAL or COMPLEX constants.
- If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
- will warn anyway, so there is no need to to so here. */
-
- if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type
- && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX))
- {
- if (lvalue->ts.kind < rvalue->ts.kind && warn_conversion)
- {
- /* As a special bonus, don't warn about REAL rvalues which are not
- changed by the conversion if -Wconversion is specified. */
- if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real))
- {
- /* Calculate the difference between the constant and the rounded
- value and check it against zero. */
- mpfr_t rv, diff;
- gfc_set_model_kind (lvalue->ts.kind);
- mpfr_init (rv);
- gfc_set_model_kind (rvalue->ts.kind);
- mpfr_init (diff);
-
- mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
- mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-
- if (!mpfr_zero_p (diff))
- gfc_warning (OPT_Wconversion,
- "Change of value in conversion from "
- " %qs to %qs at %L", gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
-
- mpfr_clear (rv);
- mpfr_clear (diff);
- }
- else
- gfc_warning (OPT_Wconversion,
- "Possible change of value in conversion from %qs "
- "to %qs at %L", gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
-
- }
- else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind)
- {
- gfc_warning (OPT_Wconversion_extra,
- "Conversion from %qs to %qs at %L",
- gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts), &rvalue->where);
- }
- }
-
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return true;
kind values can be converted into one another. */
if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
{
- if (lvalue->ts.kind != rvalue->ts.kind)
- gfc_convert_chartype (rvalue, &lvalue->ts);
-
- return true;
+ if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
+ return gfc_convert_chartype (rvalue, &lvalue->ts);
+ else
+ return true;
}
+ if (!allow_convert)
+ return true;
+
return gfc_convert_type (rvalue, &lvalue->ts, 1);
}
}
if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
- "for %qs in pointer assignment at %L",
+ "for %qs in pointer assignment at %L",
lvalue->symtree->n.sym->name, &lvalue->where))
return false;
{
char err[200];
gfc_symbol *s1,*s2;
- gfc_component *comp;
+ gfc_component *comp1, *comp2;
const char *name;
attr = gfc_expr_attr (rvalue);
}
}
- comp = gfc_get_proc_ptr_comp (lvalue);
- if (comp)
- s1 = comp->ts.interface;
+ comp1 = gfc_get_proc_ptr_comp (lvalue);
+ if (comp1)
+ s1 = comp1->ts.interface;
else
{
s1 = lvalue->symtree->n.sym;
s1 = s1->ts.interface;
}
- comp = gfc_get_proc_ptr_comp (rvalue);
- if (comp)
+ comp2 = gfc_get_proc_ptr_comp (rvalue);
+ if (comp2)
{
if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = comp->ts.interface->result;
+ s2 = comp2->ts.interface->result;
name = s2->name;
}
else
{
- s2 = comp->ts.interface;
- name = comp->name;
+ s2 = comp2->ts.interface;
+ name = comp2->name;
}
}
else if (rvalue->expr_type == EXPR_FUNCTION)
if (s2 && s2->attr.proc_pointer && s2->ts.interface)
s2 = s2->ts.interface;
+ /* Special check for the case of absent interface on the lvalue.
+ * All other interface checks are done below. */
+ if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: '%s' is not a subroutine", &rvalue->where, name);
+ return false;
+ }
+
if (s1 == s2 || !s1 || !s2)
return true;
|| (lvalue->ts.type == BT_DERIVED
&& (lvalue->ts.u.derived->attr.is_bind_c
|| lvalue->ts.u.derived->attr.sequence))))
- gfc_error ("Data-pointer-object &L must be unlimited "
- "polymorphic, a sequence derived type or of a "
- "type with the BIND attribute assignment at %L "
- "to be compatible with an unlimited polymorphic "
- "target", &lvalue->where);
+ gfc_error ("Data-pointer-object at %L must be unlimited "
+ "polymorphic, or of a type with the BIND or SEQUENCE "
+ "attribute, to be compatible with an unlimited "
+ "polymorphic target", &lvalue->where);
else
gfc_error ("Different types in pointer assignment at %L; "
"attempted assignment of %s to %s", &lvalue->where,
and F2008 must be allowed. */
if (rvalue->rank != 1)
{
- if (!gfc_is_simply_contiguous (rvalue, true))
+ if (!gfc_is_simply_contiguous (rvalue, true, false))
{
gfc_error ("Rank remapping target must be rank 1 or"
" simply contiguous at %L", &rvalue->where);
if (pointer || proc_pointer)
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
- r = gfc_check_assign (&lvalue, rvalue, 1);
+ {
+ /* If a conversion function, e.g., __convert_i8_i4, was inserted
+ into an array constructor, we should check if it can be reduced
+ as an initialization expression. */
+ if (rvalue->expr_type == EXPR_FUNCTION
+ && rvalue->value.function.isym
+ && (rvalue->value.function.isym->conversion == 1))
+ gfc_check_init_expr (rvalue);
+
+ r = gfc_check_assign (&lvalue, rvalue, 1);
+ }
free (lvalue.symtree);
free (lvalue.ref);
}
+/* 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);
+ if (!ctor->expr->ts.u.cl)
+ ctor->expr->ts.u.cl
+ = gfc_new_charlen (gfc_current_ns, ts->u.cl);
+ else
+ ctor->expr->ts.u.cl->length
+ = gfc_copy_expr (ts->u.cl->length);
+ }
+ }
+ }
+ }
+}
+
+
+/* Check whether an expression is a structure constructor and whether it has
+ other values than NULL. */
+
+bool
+is_non_empty_structure_constructor (gfc_expr * e)
+{
+ if (e->expr_type != EXPR_STRUCTURE)
+ return false;
+
+ gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
+ while (cons)
+ {
+ if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
+ return true;
+ cons = gfc_constructor_next (cons);
+ }
+ return false;
+}
+
+
/* Check for default initializer; sym->value is not enough
as it is also set for EXPR_NULL of allocatables. */
{
gfc_component *c;
- gcc_assert (der->attr.flavor == FL_DERIVED);
+ gcc_assert (gfc_fl_struct (der->attr.flavor));
for (c = der->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED)
+ if (gfc_bt_struct (c->ts.type))
{
- if (!c->attr.pointer
- && gfc_has_default_initializer (c->ts.u.derived))
+ if (!c->attr.pointer && !c->attr.proc_pointer
+ && !(c->attr.allocatable && der == c->ts.u.derived)
+ && ((c->initializer
+ && is_non_empty_structure_constructor (c->initializer))
+ || gfc_has_default_initializer (c->ts.u.derived)))
return true;
if (c->attr.pointer && c->initializer)
return true;
}
-/* Get an expression for a default initializer. */
+/*
+ Generate an initializer expression which initializes the entirety of a union.
+ A normal structure constructor is insufficient without undue effort, because
+ components of maps may be oddly aligned/overlapped. (For example if a
+ character is initialized from one map overtop a real from the other, only one
+ byte of the real is actually initialized.) Unfortunately we don't know the
+ size of the union right now, so we can't generate a proper initializer, but
+ we use a NULL expr as a placeholder and do the right thing later in
+ gfc_trans_subcomponent_assign.
+ */
+static gfc_expr *
+generate_union_initializer (gfc_component *un)
+{
+ if (un == NULL || un->ts.type != BT_UNION)
+ return NULL;
+
+ gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
+ placeholder->ts = un->ts;
+ return placeholder;
+}
+
+
+/* Get the user-specified initializer for a union, if any. This means the user
+ has said to initialize component(s) of a map. For simplicity's sake we
+ only allow the user to initialize the first map. We don't have to worry
+ about overlapping initializers as they are released early in resolution (see
+ resolve_fl_struct). */
+
+static gfc_expr *
+get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
+{
+ gfc_component *map;
+ gfc_expr *init=NULL;
+
+ if (!union_type || union_type->attr.flavor != FL_UNION)
+ return NULL;
+
+ for (map = union_type->components; map; map = map->next)
+ {
+ if (gfc_has_default_initializer (map->ts.u.derived))
+ {
+ init = gfc_default_initializer (&map->ts);
+ if (map_p)
+ *map_p = map;
+ break;
+ }
+ }
+
+ if (map_p && !init)
+ *map_p = NULL;
+
+ return init;
+}
+
+/* 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);
+
+ else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
+ {
+ gfc_component *map = NULL;
+ gfc_constructor *ctor;
+ gfc_expr *user_init;
+
+ /* If we don't have a user initializer and we aren't generating one, this
+ union has no initializer. */
+ user_init = get_union_initializer (c->ts.u.derived, &map);
+ if (!user_init && !generate)
+ return NULL;
+
+ /* Otherwise use a structure constructor. */
+ init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
+ &c->loc);
+ init->ts = c->ts;
+
+ /* If we are to generate an initializer for the union, add a constructor
+ which initializes the whole union first. */
+ if (generate)
+ {
+ ctor = gfc_constructor_get ();
+ ctor->expr = generate_union_initializer (c);
+ gfc_constructor_append (&init->value.constructor, ctor);
+ }
+
+ /* If we found an initializer in one of our maps, apply it. Note this
+ is applied _after_ the entire-union initializer above if any. */
+ if (user_init)
+ {
+ ctor = gfc_constructor_get ();
+ ctor->expr = user_init;
+ ctor->n.component = map;
+ gfc_constructor_append (&init->value.constructor, ctor);
+ }
+ }
+
+ /* 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)
{
- ctor->expr = gfc_copy_expr (comp->initializer);
- if ((comp->ts.type != comp->initializer->ts.type
- || comp->ts.kind != comp->initializer->ts.kind)
+ /* 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;
+
+ /* 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);
}
{
ctor->expr = gfc_get_expr ();
ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->where = init->where;
ctor->expr->ts = comp->ts;
}
return true;
}
+gfc_expr *
+gfc_find_stat_co(gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.stat;
+
+ if (e->value.function.actual->expr)
+ for (ref = e->value.function.actual->expr->ref; ref;
+ ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return ref->u.ar.stat;
+
+ return NULL;
+}
bool
gfc_is_coindexed (gfc_expr *e)
a "(::1)" is accepted. */
bool
-gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
{
bool colon;
int i;
else if (expr->expr_type != EXPR_VARIABLE)
return false;
- if (expr->rank == 0)
+ if (!permit_element && expr->rank == 0)
return false;
for (ref = expr->ref; ref; ref = ref->next)
return false;
}
+ if (e->ts.type == BT_DERIVED
+ && e->ts.u.derived == NULL)
+ {
+ if (context)
+ gfc_error ("Type inaccessible in variable definition context (%s) "
+ "at %L", context, &e->where);
+ return false;
+ }
+
/* F2008, C1303. */
if (!alloc_obj
&& (attr.lock_comp
return false;
}
+ /* TS18508, C702/C203. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
+ context, &e->where);
+ return false;
+ }
+
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
component of sub-component of a pointer; we need to distinguish
assignment to a pointer component from pointer-assignment to a pointer
component. Note that (normal) assignment to procedure pointers is not
possible. */
check_intentin = !own_scope;
- ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
+ && CLASS_DATA (sym))
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next)
{
{
gfc_constructor *c, *n;
gfc_expr *ec, *en;
-
+
for (c = gfc_constructor_first (arr->value.constructor);
c != NULL; c = gfc_constructor_next (c))
{
if (c == NULL || c->iterator != NULL)
continue;
-
+
ec = c->expr;
for (n = gfc_constructor_next (c); n != NULL;
{
if (n->iterator != NULL)
continue;
-
+
en = n->expr;
if (gfc_dep_compare_expr (ec, en) == 0)
{
}
}
}
-
+
return true;
}
projects / thirdparty / gcc.git / blobdiff