2009-08-13 Janus Weil <janus@gcc.gnu.org>
+ PR fortran/40941
+ * gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union.
+ * decl.c (build_struct): Make sure 'cl' is only used
+ if type is BT_CHARACTER.
+ * symbol.c (gfc_set_default_type): Ditto.
+ * resolve.c (resolve_symbol, resolve_fl_derived): Ditto.
+ (resolve_equivalence,resolve_equivalence_derived): Make sure 'derived'
+ is only used if type is BT_DERIVED.
+ * trans-io.c (transfer_expr): Make sure 'derived' is only used if type
+ is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR).
+ * array.c: Mechanical replacements to accomodate union in gfc_typespec.
+ * check.c: Ditto.
+ * data.c: Ditto.
+ * decl.c: Ditto.
+ * dump-parse-tree.c: Ditto.
+ * expr.c: Ditto.
+ * interface.c: Ditto.
+ * iresolve.c: Ditto.
+ * match.c: Ditto.
+ * misc.c: Ditto.
+ * module.c: Ditto.
+ * openmp.c: Ditto.
+ * parse.c: Ditto.
+ * primary.c: Ditto.
+ * resolve.c: Ditto.
+ * simplify.c: Ditto.
+ * symbol.c: Ditto.
+ * target-memory.c: Ditto.
+ * trans-array.c: Ditto.
+ * trans-common.c: Ditto.
+ * trans-const.c: Ditto.
+ * trans-decl.c: Ditto.
+ * trans-expr.c: Ditto.
+ * trans-intrinsic.c: Ditto.
+ * trans-io.c: Ditto.
+ * trans-stmt.c: Ditto.
+ * trans-types.c: Ditto.
+
+2009-08-13 Janus Weil <janus@gcc.gnu.org>
+
PR fortran/40995
* resolve.c (resolve_symbol): Move some checking code to
resolve_intrinsic, and call this from here.
else
expr->ts.type = BT_UNKNOWN;
- if (expr->ts.cl)
- expr->ts.cl->length_from_typespec = seen_ts;
+ if (expr->ts.u.cl)
+ expr->ts.u.cl->length_from_typespec = seen_ts;
expr->where = where;
expr->rank = 1;
gcc_assert (expr->expr_type == EXPR_ARRAY);
gcc_assert (expr->ts.type == BT_CHARACTER);
- if (expr->ts.cl == NULL)
+ if (expr->ts.u.cl == NULL)
{
for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->ts.cl != NULL)
+ if (p->expr->ts.u.cl != NULL)
{
/* Ensure that if there is a char_len around that it is
used; otherwise the middle-end confuses them! */
- expr->ts.cl = p->expr->ts.cl;
+ expr->ts.u.cl = p->expr->ts.u.cl;
goto got_charlen;
}
- expr->ts.cl = gfc_new_charlen (gfc_current_ns);
+ expr->ts.u.cl = gfc_new_charlen (gfc_current_ns);
}
got_charlen:
found_length = -1;
- if (expr->ts.cl->length == NULL)
+ if (expr->ts.u.cl->length == NULL)
{
/* Check that all constant string elements have the same length until
we reach the end or find a variable-length one. */
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
current_length = (int) j;
}
- else if (p->expr->ts.cl && p->expr->ts.cl->length
- && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
+ && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
long j;
- j = mpz_get_si (p->expr->ts.cl->length->value.integer);
+ j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
current_length = (int) j;
}
else
gcc_assert (found_length != -1);
/* Update the character length of the array constructor. */
- expr->ts.cl->length = gfc_int_expr (found_length);
+ expr->ts.u.cl->length = gfc_int_expr (found_length);
}
else
{
/* We've got a character length specified. It should be an integer,
otherwise an error is signalled elsewhere. */
- gcc_assert (expr->ts.cl->length);
+ gcc_assert (expr->ts.u.cl->length);
/* If we've got a constant character length, pad according to this.
gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
max_length only if they pass. */
- gfc_extract_int (expr->ts.cl->length, &found_length);
+ gfc_extract_int (expr->ts.u.cl->length, &found_length);
/* Now pad/truncate the elements accordingly to the specified character
length. This is ok inside this conditional, as in the case above
int current_length = -1;
bool has_ts;
- if (p->expr->ts.cl && p->expr->ts.cl->length)
+ if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
{
- cl = p->expr->ts.cl->length;
+ cl = p->expr->ts.u.cl->length;
gfc_extract_int (cl, ¤t_length);
}
/* If gfc_extract_int above set current_length, we implicitly
know the type is BT_INTEGER and it's EXPR_CONSTANT. */
- has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
+ has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
if (! cl
|| (current_length != -1 && current_length < found_length))
long len_a, len_b;
len_a = len_b = -1;
- if (a->ts.cl && a->ts.cl->length
- && a->ts.cl->length->expr_type == EXPR_CONSTANT)
- len_a = mpz_get_si (a->ts.cl->length->value.integer);
+ if (a->ts.u.cl && a->ts.u.cl->length
+ && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
else if (a->expr_type == EXPR_CONSTANT
- && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+ && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
len_a = a->value.character.length;
else
return SUCCESS;
- if (b->ts.cl && b->ts.cl->length
- && b->ts.cl->length->expr_type == EXPR_CONSTANT)
- len_b = mpz_get_si (b->ts.cl->length->value.integer);
+ if (b->ts.u.cl && b->ts.u.cl->length
+ && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
else if (b->expr_type == EXPR_CONSTANT
- && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+ && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
len_b = b->value.character.length;
else
return SUCCESS;
{
/* Check that the argument is length one. Non-constant lengths
can't be checked here, so assume they are ok. */
- if (c->ts.cl && c->ts.cl->length)
+ if (c->ts.u.cl && c->ts.u.cl->length)
{
/* If we already have a length for this expression then use it. */
- if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return SUCCESS;
- i = mpz_get_si (c->ts.cl->length->value.integer);
+ i = mpz_get_si (c->ts.u.cl->length->value.integer);
}
else
return SUCCESS;
int len, start, end;
gfc_char_t *dest;
- gfc_extract_int (ts->cl->length, &len);
+ gfc_extract_int (ts->u.cl->length, &len);
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
- expr->ts.derived = ref->u.c.sym;
+ expr->ts.u.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
if (ref || last_ts->type == BT_CHARACTER)
{
- if (lvalue->ts.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
+ if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
return FAILURE;
expr = create_character_intializer (init, last_ts, ref, rvalue);
}
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
- expr->ts.derived = ref->u.c.sym;
+ expr->ts.u.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
return;
head = tail = NULL;
- for (order = expr->ts.derived->components; order; order = order->next)
+ for (order = expr->ts.u.derived->components; order; order = order->next)
{
/* Find the next component. */
last = NULL;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
goto syntax;
if (e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl
- && e->symtree->n.sym->ts.cl->length->ts.type == BT_UNKNOWN)
+ && e->symtree->n.sym->ts.u.cl
+ && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
goto syntax;
}
}
"because derived type '%s' is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
- sym->ts.derived->name);
+ sym->ts.u.derived->name);
else
gfc_warning ("Variable '%s' at %L is a parameter to the "
"BIND(C) procedure '%s' but may not be C "
length of 1. */
if (sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
- sym->ts.cl = cl;
+ sym->ts.u.cl = cl;
/* Add dimension attribute if present. */
if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
- if (sym->ts.type == BT_CHARACTER && sym->ts.cl
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
&& init->ts.type == BT_CHARACTER)
{
/* Update symbol character length according initializer. */
if (gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
- if (sym->ts.cl->length == NULL)
+ if (sym->ts.u.cl->length == NULL)
{
int clen;
/* If there are multiple CHARACTER variables declared on the
same line, we don't want them to share the same length. */
- sym->ts.cl = gfc_new_charlen (gfc_current_ns);
+ sym->ts.u.cl = gfc_new_charlen (gfc_current_ns);
if (sym->attr.flavor == FL_PARAMETER)
{
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
gfc_expr *p = init->value.constructor->expr;
clen = p->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
- else if (init->ts.cl && init->ts.cl->length)
- sym->ts.cl->length =
- gfc_copy_expr (sym->value->ts.cl->length);
+ else if (init->ts.u.cl && init->ts.u.cl->length)
+ sym->ts.u.cl->length =
+ gfc_copy_expr (sym->value->ts.u.cl->length);
}
}
/* Update initializer character length according symbol. */
- else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- int len = mpz_get_si (sym->ts.cl->length->value.integer);
+ int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
{
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
- init->ts.cl = gfc_new_charlen (gfc_current_ns);
- init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
+ init->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
for (p = init->value.constructor; p; p = p->next)
gfc_set_constant_character_len (len, p->expr, -1);
/* If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
if (current_ts.type == BT_DERIVED
- && current_ts.derived == gfc_current_block ()
+ && current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
gfc_error ("Component at %C must have the POINTER attribute");
return FAILURE;
c->ts = current_ts;
- c->ts.cl = cl;
+ if (c->ts.type == BT_CHARACTER)
+ c->ts.u.cl = cl;
c->attr = current_attr;
c->initializer = *init;
/* 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.cl
- && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
+ 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.cl && c->ts.cl->length);
- gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT);
- gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER);
+ 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.cl->length->value.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.cl->length->value.integer,
- c->initializer->ts.cl->length->value.integer))
+ else if (mpz_cmp (c->ts.u.cl->length->value.integer,
+ c->initializer->ts.u.cl->length->value.integer))
{
bool has_ts;
gfc_constructor *ctor = c->initializer->value.constructor;
- has_ts = (c->initializer->ts.cl
- && c->initializer->ts.cl->length_from_typespec);
+ has_ts = (c->initializer->ts.u.cl
+ && c->initializer->ts.u.cl->length_from_typespec);
if (ctor)
{
element. Also copy assumed lengths. */
case MATCH_NO:
if (elem > 1
- && (current_ts.cl->length == NULL
- || current_ts.cl->length->expr_type != EXPR_CONSTANT))
+ && (current_ts.u.cl->length == NULL
+ || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
{
cl = gfc_new_charlen (gfc_current_ns);
- cl->length = gfc_copy_expr (current_ts.cl->length);
+ cl->length = gfc_copy_expr (current_ts.u.cl->length);
}
else
- cl = current_ts.cl;
+ cl = current_ts.u.cl;
break;
{
sym->ts.type = current_ts.type;
sym->ts.kind = current_ts.kind;
- sym->ts.cl = cl;
- sym->ts.derived = current_ts.derived;
+ sym->ts.u.cl = cl;
+ sym->ts.u.derived = current_ts.u.derived;
sym->ts.is_c_interop = current_ts.is_c_interop;
sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES;
if (current_ts.type == BT_DERIVED
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
- && current_ts.derived->ns != gfc_current_ns)
+ && current_ts.u.derived->ns != gfc_current_ns)
{
gfc_symtree *st;
- st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
- if (!(current_ts.derived->attr.imported
+ st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
+ if (!(current_ts.u.derived->attr.imported
&& st != NULL
- && st->n.sym == current_ts.derived)
+ && st->n.sym == current_ts.u.derived)
&& !gfc_current_ns->has_import_set)
{
gfc_error ("the type of '%s' at %C has not been declared within the "
else
cl->length = len;
- ts->cl = cl;
+ ts->u.cl = cl;
ts->kind = kind == 0 ? gfc_default_character_kind : kind;
/* We have to know if it was a c interoperable kind so we can
found, add it to the typespec. */
if (gfc_matching_function)
{
- ts->derived = NULL;
+ ts->u.derived = NULL;
if (gfc_current_state () != COMP_INTERFACE
&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
- ts->derived = sym;
+ ts->u.derived = sym;
return MATCH_YES;
}
return MATCH_ERROR;
gfc_set_sym_referenced (sym);
- ts->derived = sym;
+ ts->u.derived = sym;
return MATCH_YES;
if ((c == '\n') || (c == ','))
{
/* Check for CHARACTER with no length parameter. */
- if (ts.type == BT_CHARACTER && !ts.cl)
+ if (ts.type == BT_CHARACTER && !ts.u.cl)
{
ts.kind = gfc_default_character_kind;
- ts.cl = gfc_new_charlen (gfc_current_ns);
- ts.cl->length = gfc_int_expr (1);
+ ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ ts.u.cl->length = gfc_int_expr (1);
}
/* Record the Successful match. */
gfc_try
verify_c_interop (gfc_typespec *ts)
{
- if (ts->type == BT_DERIVED && ts->derived != NULL)
- return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ if (ts->type == BT_DERIVED && ts->u.derived != NULL)
+ return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
else if (ts->is_c_interop != 1)
return FAILURE;
/* BIND(C) functions can not return a character string. */
if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
- if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
- || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
+ if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
+ || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
{
- sym = gfc_use_derived (current_ts.derived);
+ sym = gfc_use_derived (current_ts.u.derived);
if (sym == NULL)
{
goto cleanup;
}
- current_ts.derived = sym;
+ current_ts.u.derived = sym;
}
m = match_attr_spec ();
goto cleanup;
}
- if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL
- && !current_ts.derived->attr.zero_comp)
+ if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+ && !current_ts.u.derived->attr.zero_comp)
{
if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
goto ok;
- gfc_find_symbol (current_ts.derived->name,
- current_ts.derived->ns->parent, 1, &sym);
+ gfc_find_symbol (current_ts.u.derived->name,
+ current_ts.u.derived->ns->parent, 1, &sym);
/* Any symbol that we find had better be a type definition
which has its components defined. */
if (sym != NULL && sym->attr.flavor == FL_DERIVED
- && (current_ts.derived->components != NULL
- || current_ts.derived->attr.zero_comp))
+ && (current_ts.u.derived->components != NULL
+ || current_ts.u.derived->attr.zero_comp))
goto ok;
/* Now we have an error, which we signal, and then fix up
}
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl != NULL
- && sym->ts.cl->length != NULL
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT
+ && sym->ts.u.cl != NULL
+ && sym->ts.u.cl->length != NULL
+ && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& init->expr_type == EXPR_CONSTANT
&& init->ts.type == BT_CHARACTER)
gfc_set_constant_character_len (
- mpz_get_si (sym->ts.cl->length->value.integer), init, -1);
- else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL
- && sym->ts.cl->length == NULL)
+ mpz_get_si (sym->ts.u.cl->length->value.integer), init, -1);
+ else if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl != NULL
+ && sym->ts.u.cl->length == NULL)
{
int clen;
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
gfc_expr *p = init->value.constructor->expr;
clen = p->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
- else if (init->ts.cl && init->ts.cl->length)
- sym->ts.cl->length = gfc_copy_expr (sym->value->ts.cl->length);
+ else if (init->ts.u.cl && init->ts.u.cl->length)
+ sym->ts.u.cl->length = gfc_copy_expr (sym->value->ts.u.cl->length);
}
sym->value = init;
gfc_set_sym_referenced (extended);
p->ts.type = BT_DERIVED;
- p->ts.derived = extended;
+ p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
/* Provide the links between the extended type and its extension. */
switch (ts->type)
{
case BT_DERIVED:
- fprintf (dumpfile, "%s", ts->derived->name);
+ fprintf (dumpfile, "%s", ts->u.derived->name);
break;
case BT_CHARACTER:
- show_expr (ts->cl->length);
+ show_expr (ts->u.cl->length);
break;
default:
break;
case EXPR_STRUCTURE:
- fprintf (dumpfile, "%s(", p->ts.derived->name);
+ fprintf (dumpfile, "%s(", p->ts.u.derived->name);
show_constructor (p->value.constructor);
fputc (')', dumpfile);
break;
else
string_len = 0;
- if (!p->ts.cl)
+ if (!p->ts.u.cl)
{
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = NULL;
- p->ts.cl->length = NULL;
+ p->ts.u.cl = gfc_get_charlen ();
+ p->ts.u.cl->next = NULL;
+ p->ts.u.cl->length = NULL;
}
- gfc_free_expr (p->ts.cl->length);
- p->ts.cl->length = gfc_int_expr (string_len);
+ gfc_free_expr (p->ts.u.cl->length);
+ p->ts.u.cl->length = gfc_int_expr (string_len);
}
}
gfc_free_ref_list (p->ref);
gfc_free (p->value.character.string);
p->value.character.string = s;
p->value.character.length = end - start;
- p->ts.cl = gfc_new_charlen (gfc_current_ns);
- p->ts.cl->length = gfc_int_expr (p->value.character.length);
+ p->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
gfc_free_ref_list (p->ref);
p->ref = NULL;
p->expr_type = EXPR_CONSTANT;
with LEN, as required by the standard. */
if (i == 5 && not_restricted
&& ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
- && ap->expr->symtree->n.sym->ts.cl->length == NULL)
+ && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length variable '%s' in constant "
"expression at %L", e->symtree->n.sym->name, &e->where);
gfc_component *c;
/* See if we have a default initializer. */
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
if (c->initializer || c->attr.allocatable)
break;
init = gfc_get_expr ();
init->expr_type = EXPR_STRUCTURE;
init->ts = *ts;
- init->where = ts->derived->declared_at;
+ init->where = ts->u.derived->declared_at;
tail = NULL;
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
if (tail == NULL)
init->value.constructor = tail = gfc_get_constructor ();
return true;
if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl
- && expr->ts.cl->length
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT
- && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ && expr->ts.u.cl
+ && expr->ts.u.cl->length
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
return true;
switch (expr->expr_type)
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl
- && ref->u.c.component->ts.cl->length
- && ref->u.c.component->ts.cl->length->expr_type
+ && ref->u.c.component->ts.u.cl
+ && ref->u.c.component->ts.u.cl->length
+ && ref->u.c.component->ts.u.cl->length->expr_type
!= EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
sym, func, f))
return true;
#define gfc_get_charlen() XCNEW (gfc_charlen)
-/* Type specification structure. FIXME: derived and cl could be union??? */
+/* Type specification structure. */
typedef struct
{
bt type;
int kind;
- struct gfc_symbol *derived;
- gfc_charlen *cl; /* For character types only. */
+
+ union
+ {
+ struct gfc_symbol *derived; /* For derived types only. */
+ gfc_charlen *cl; /* For character types only. */
+ }
+ u;
+
struct gfc_symbol *interface; /* For PROCEDURE declarations. */
unsigned int is_class:1;
int is_c_interop;
/* Make sure that link lists do not put this function into an
endless recursive loop! */
- if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
- && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+ if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
&& gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
return 0;
- else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
- && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+ else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
return 0;
- else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
- && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+ else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
return 0;
dt1 = dt1->next;
return (ts1->kind == ts2->kind);
/* Compare derived types. */
- if (ts1->derived == ts2->derived)
+ if (ts1->u.derived == ts2->u.derived)
return 1;
- return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+ return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
}
return 1;
if (formal->ts.type == BT_DERIVED
- && formal->ts.derived && formal->ts.derived->ts.is_iso_c
+ && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
&& actual->ts.type == BT_DERIVED
- && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
+ && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
return 1;
if (actual->ts.type == BT_PROCEDURE)
if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl && sym->ts.cl->length
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
- strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+ if (sym->ts.u.cl && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
else
return 0;
}
if (e->ts.type == BT_CHARACTER)
{
- if (e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
- strlen = mpz_get_si (e->ts.cl->length->value.integer);
+ if (e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
else if (e->expr_type == EXPR_CONSTANT
- && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
strlen = e->value.character.length;
else
return 0;
and assumed-shape dummies, the string length needs to match
exactly. */
if (a->expr->ts.type == BT_CHARACTER
- && a->expr->ts.cl && a->expr->ts.cl->length
- && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
- && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
- && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
+ && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+ && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
+ && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& (f->sym->attr.pointer || f->sym->attr.allocatable
|| (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
- && (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) != 0))
+ && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
+ f->sym->ts.u.cl->length->value.integer) != 0))
{
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
"argument and pointer or allocatable dummy argument "
"'%s' at %L",
- mpz_get_si (a->expr->ts.cl->length->value.integer),
- mpz_get_si (f->sym->ts.cl->length->value.integer),
+ mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
else if (where)
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
"argument and assumed-shape dummy argument '%s' "
"at %L",
- mpz_get_si (a->expr->ts.cl->length->value.integer),
- mpz_get_si (f->sym->ts.cl->length->value.integer),
+ mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
return 0;
}
static void
check_charlen_present (gfc_expr *source)
{
- if (source->ts.cl == NULL)
- source->ts.cl = gfc_new_charlen (gfc_current_ns);
+ if (source->ts.u.cl == NULL)
+ source->ts.u.cl = gfc_new_charlen (gfc_current_ns);
if (source->expr_type == EXPR_CONSTANT)
{
- source->ts.cl->length = gfc_int_expr (source->value.character.length);
+ source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
source->rank = 0;
}
else if (source->expr_type == EXPR_ARRAY)
- source->ts.cl->length =
+ source->ts.u.cl->length =
gfc_int_expr (source->value.constructor->expr->value.character.length);
}
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL)
? gfc_default_character_kind : mpz_get_si (kind->value.integer);
- f->ts.cl = gfc_new_charlen (gfc_current_ns);
- f->ts.cl->length = gfc_int_expr (1);
+ f->ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ f->ts.u.cl->length = gfc_int_expr (1);
f->value.function.name = gfc_get_string (name, f->ts.kind,
gfc_type_letter (x->ts.type),
{
ts.type = BT_INTEGER;
ts.kind = 8;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (time, &ts, 2);
}
{
ts.type = BT_LOGICAL;
ts.kind = gfc_default_integer_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (back, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
if (mold->ts.type == BT_CHARACTER
- && !mold->ts.cl->length
+ && !mold->ts.u.cl->length
&& gfc_is_constant_expr (mold))
{
int len;
if (mold->expr_type == EXPR_CONSTANT)
- mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
+ mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
else
{
len = mold->value.constructor->expr->value.character.length;
- mold->ts.cl->length = gfc_int_expr (len);
+ mold->ts.u.cl->length = gfc_int_expr (len);
}
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (unit, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = 8;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (u, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (unit, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_intio_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (offset, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (whence, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (unit, &ts, 2);
}
{
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- ts.derived = NULL;
- ts.cl = NULL;
+ ts.u.derived = NULL;
+ ts.u.cl = NULL;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
}
if (tail->expr->ts.type == BT_DERIVED)
- tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+ tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
/* FIXME: disable the checking on derived types and arrays. */
if (!(tail->expr->ref
gfc_error_check ();
}
- if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length '%s' in namelist '%s' at "
"%C is not allowed", sym->name, group_name->name);
gfc_clear_ts (gfc_typespec *ts)
{
ts->type = BT_UNKNOWN;
- ts->derived = NULL;
+ ts->u.derived = NULL;
ts->kind = 0;
- ts->cl = NULL;
+ ts->u.cl = NULL;
ts->interface = NULL;
ts->is_class = 0;
/* flag that says if the type is C interoperable */
sprintf (buffer, "HOLLERITH");
break;
case BT_DERIVED:
- sprintf (buffer, "TYPE(%s)", ts->derived->name);
+ sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
break;
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
if (ts->type != BT_DERIVED)
mio_integer (&ts->kind);
else
- mio_symbol_ref (&ts->derived);
+ mio_symbol_ref (&ts->u.derived);
/* Add info for C interop and is_iso_c. */
mio_integer (&ts->is_c_interop);
if (ts->type != BT_CHARACTER)
{
- /* ts->cl is only valid for BT_CHARACTER. */
+ /* ts->u.cl is only valid for BT_CHARACTER. */
mio_lparen ();
mio_rparen ();
}
else
- mio_charlen (&ts->cl);
+ mio_charlen (&ts->u.cl);
mio_rparen ();
}
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, &code->loc);
- if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
+ if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, &code->loc);
- if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
+ if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
}
n->sym->name, name, &code->loc);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
- n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
+ n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
name, n->sym->name, &code->loc);
if (n->sym->attr.cray_pointer)
{
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
sym->attr.alloc_comp = 1;
/* Look for pointer components. */
if (c->attr.pointer
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
sym->attr.pointer_comp = 1;
/* Look for procedure pointer components. */
if (c->attr.proc_pointer
|| (c->ts.type == BT_DERIVED
- && c->ts.derived->attr.proc_pointer_comp))
+ && c->ts.u.derived->attr.proc_pointer_comp))
sym->attr.proc_pointer_comp = 1;
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
sym->attr.private_comp = 1;
}
{
ts->kind = 0;
- if (!ts->derived || !ts->derived->components)
+ if (!ts->u.derived || !ts->u.derived->components)
m = MATCH_ERROR;
}
/* Check type-parameters, at the moment only CHARACTER lengths possible. */
/* TODO: Extend when KIND type parameters are implemented. */
- if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
- gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
+ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
+ gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
}
gfc_current_block ()->ts.kind = 0;
/* Keep the derived type; if it's bad, it will be discovered later. */
- if (!(ts->type == BT_DERIVED && ts->derived))
+ if (!(ts->type == BT_DERIVED && ts->u.derived))
ts->type = BT_UNKNOWN;
}
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
- sym = sym->ts.derived;
+ sym = sym->ts.u.derived;
for (;;)
{
|| gfc_match_char ('%') != MATCH_YES)
break;
- sym = component->ts.derived;
+ sym = component->ts.u.derived;
}
check_substring:
if (primary->ts.type == BT_CHARACTER)
{
- switch (match_substring (primary->ts.cl, equiv_flag, &substring))
+ switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
{
case MATCH_YES:
if (tail == NULL)
primary->expr_type = EXPR_SUBSTRING;
if (substring)
- primary->ts.cl = NULL;
+ primary->ts.u.cl = NULL;
break;
follows. */
if (ts->type == BT_CHARACTER
&& ref->next && ref->next->type == REF_SUBSTRING)
- ts->cl = NULL;
+ ts->u.cl = NULL;
}
pointer = ref->u.c.component->attr.pointer;
value->where = gfc_current_locus;
if (build_actual_constructor (comp_head, &value->value.constructor,
- comp->ts.derived) == FAILURE)
+ comp->ts.u.derived) == FAILURE)
{
gfc_free_expr (value);
return FAILURE;
&& sym->attr.extension
&& (comp_tail->val->ts.type != BT_DERIVED
||
- comp_tail->val->ts.derived != this_comp->ts.derived))
+ comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
{
gfc_current_locus = where;
gfc_free_expr (comp_tail->val);
comp_tail->val = NULL;
- m = gfc_match_structure_constructor (comp->ts.derived,
+ m = gfc_match_structure_constructor (comp->ts.u.derived,
&comp_tail->val, true);
if (m == MATCH_NO)
goto syntax;
e->expr_type = EXPR_STRUCTURE;
e->ts.type = BT_DERIVED;
- e->ts.derived = sym;
+ e->ts.u.derived = sym;
e->where = where;
e->value.constructor = ctor_head;
that we're not sure is a variable yet. */
if ((implicit_char || sym->ts.type == BT_CHARACTER)
- && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
+ && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
{
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
if (e->ref)
- e->ts.cl = NULL;
+ e->ts.u.cl = NULL;
m = MATCH_YES;
break;
}
type may still have to be resolved. */
if (sym->ts.type == BT_DERIVED
- && gfc_use_derived (sym->ts.derived) == NULL)
+ && gfc_use_derived (sym->ts.u.derived) == NULL)
return MATCH_ERROR;
break;
}
static gfc_try
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
{
- if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
+ if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
{
if (where)
{
if (name)
gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
- name, where, ts->derived->name);
+ name, where, ts->u.derived->name);
else
gfc_error ("ABSTRACT type '%s' used at %L",
- ts->derived->name, where);
+ ts->u.derived->name, where);
}
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Character-valued argument '%s' of statement "
if (sym->result->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->result->ts.cl;
+ gfc_charlen *cl = sym->result->ts.u.cl;
if (!cl || !cl->length)
gfc_error ("Character-valued internal function '%s' at %L must "
"not be assumed length", sym->name, &sym->declared_at);
the same string length, i.e. both len=*, or both len=4.
Having both len=<variable> is also possible, but difficult to
check at compile time. */
- else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
- && (((ts->cl->length && !fts->cl->length)
- ||(!ts->cl->length && fts->cl->length))
- || (ts->cl->length
- && ts->cl->length->expr_type
- != fts->cl->length->expr_type)
- || (ts->cl->length
- && ts->cl->length->expr_type == EXPR_CONSTANT
- && mpz_cmp (ts->cl->length->value.integer,
- fts->cl->length->value.integer) != 0)))
+ else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
+ && (((ts->u.cl->length && !fts->u.cl->length)
+ ||(!ts->u.cl->length && fts->u.cl->length))
+ || (ts->u.cl->length
+ && ts->u.cl->length->expr_type
+ != fts->u.cl->length->expr_type)
+ || (ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ts->u.cl->length->value.integer,
+ fts->u.cl->length->value.integer) != 0)))
gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
"entries returning variables of different "
"string lengths", ns->entries->sym->name,
for (c = der->components; c; c = c->next)
if ((c->ts.type != BT_DERIVED && c->initializer)
|| (c->ts.type == BT_DERIVED
- && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
+ && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
break;
return c != NULL;
if (csym->ts.type != BT_DERIVED)
continue;
- if (!(csym->ts.derived->attr.sequence
- || csym->ts.derived->attr.is_bind_c))
+ if (!(csym->ts.u.derived->attr.sequence
+ || csym->ts.u.derived->attr.is_bind_c))
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"has neither the SEQUENCE nor the BIND(C) "
"attribute", csym->name, &csym->declared_at);
- if (csym->ts.derived->attr.alloc_comp)
+ if (csym->ts.u.derived->attr.alloc_comp)
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"has an ultimate component that is "
"allocatable", csym->name, &csym->declared_at);
- if (has_default_initializer (csym->ts.derived))
+ if (has_default_initializer (csym->ts.u.derived))
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"may not have default initializer", csym->name,
&csym->declared_at);
if (expr->ref)
comp = expr->ref->u.c.sym->components;
else
- comp = expr->ts.derived->components;
+ comp = expr->ts.u.derived->components;
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
- if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
+ if (expr->ts.u.derived && expr->ts.u.derived->ts.is_iso_c && cons
&& cons->expr != NULL)
{
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
- expr->ts.derived->name, &(expr->where));
+ expr->ts.u.derived->name, &(expr->where));
return FAILURE;
}
its length is one. */
if (expr->ts.type == BT_CHARACTER)
{
- if (expr->ts.cl == NULL
- || expr->ts.cl->length == NULL
- || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
+ if (expr->ts.u.cl == NULL
+ || expr->ts.u.cl->length == NULL
+ || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
!= 0)
retval = FAILURE;
}
else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
{
/* Character string. Make sure it's of length 1. */
- if (expr->ts.cl == NULL
- || expr->ts.cl->length == NULL
- || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
+ if (expr->ts.u.cl == NULL
+ || expr->ts.u.cl->length == NULL
+ || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
retval = FAILURE;
}
else if (expr->rank != 0)
any type should be ok if the variable is of a C
interoperable type. */
if (arg_ts->type == BT_CHARACTER)
- if (arg_ts->cl != NULL
- && (arg_ts->cl->length == NULL
- || arg_ts->cl->length->expr_type
+ if (arg_ts->u.cl != NULL
+ && (arg_ts->u.cl->length == NULL
+ || arg_ts->u.cl->length->expr_type
!= EXPR_CONSTANT
|| mpz_cmp_si
- (arg_ts->cl->length->value.integer, 1)
+ (arg_ts->u.cl->length->value.integer, 1)
!= 0)
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
&expr->value.function.actual, 0);
if (sym && sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && sym->ts.cl->length == NULL
+ && sym->ts.u.cl
+ && sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
&& expr->value.function.esym->attr.use_assoc)
{
- gfc_expr_set_symbols_referenced (expr->ts.cl->length);
+ gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
}
if (t == SUCCESS
case INTRINSIC_PARENTHESES:
e->ts = op1->ts;
if (e->ts.type == BT_CHARACTER)
- e->ts.cl = op1->ts.cl;
+ e->ts.u.cl = op1->ts.u.cl;
break;
default:
case REF_COMPONENT:
if (derived == NULL)
- derived = e->symtree->n.sym->ts.derived;
+ derived = e->symtree->n.sym->ts.u.derived;
c = derived->components;
{
/* Track the sequence of component references. */
if (c->ts.type == BT_DERIVED)
- derived = c->ts.derived;
+ derived = c->ts.u.derived;
break;
}
gcc_assert (char_ref->next == NULL);
- if (e->ts.cl)
+ if (e->ts.u.cl)
{
- if (e->ts.cl->length)
- gfc_free_expr (e->ts.cl->length);
+ if (e->ts.u.cl->length)
+ gfc_free_expr (e->ts.u.cl->length);
else if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.dummy)
return;
e->ts.type = BT_CHARACTER;
e->ts.kind = gfc_default_character_kind;
- if (!e->ts.cl)
- e->ts.cl = gfc_new_charlen (gfc_current_ns);
+ if (!e->ts.u.cl)
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
if (char_ref->u.ss.start)
start = gfc_copy_expr (char_ref->u.ss.start);
if (char_ref->u.ss.end)
end = gfc_copy_expr (char_ref->u.ss.end);
else if (e->expr_type == EXPR_VARIABLE)
- end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+ end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
else
end = NULL;
return;
/* Length = (end - start +1). */
- e->ts.cl->length = gfc_subtract (end, start);
- e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+ e->ts.u.cl->length = gfc_subtract (end, start);
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
- e->ts.cl->length->ts.type = BT_INTEGER;
- e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
+ e->ts.u.cl->length->ts.type = BT_INTEGER;
+ e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
/* Make sure that the length is simplified. */
- gfc_simplify_expr (e->ts.cl->length, 1);
- gfc_resolve_expr (e->ts.cl->length);
+ gfc_simplify_expr (e->ts.u.cl->length, 1);
+ gfc_resolve_expr (e->ts.u.cl->length);
}
/* Now do the same check on the specification expressions. */
specification_expr = 1;
if (sym->ts.type == BT_CHARACTER
- && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
+ && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
t = FAILURE;
if (sym->as)
gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
- if (op1->ts.cl && op1->ts.cl->length)
- e1 = gfc_copy_expr (op1->ts.cl->length);
+ if (op1->ts.u.cl && op1->ts.u.cl->length)
+ e1 = gfc_copy_expr (op1->ts.u.cl->length);
else if (op1->expr_type == EXPR_CONSTANT)
e1 = gfc_int_expr (op1->value.character.length);
- if (op2->ts.cl && op2->ts.cl->length)
- e2 = gfc_copy_expr (op2->ts.cl->length);
+ if (op2->ts.u.cl && op2->ts.u.cl->length)
+ e2 = gfc_copy_expr (op2->ts.u.cl->length);
else if (op2->expr_type == EXPR_CONSTANT)
e2 = gfc_int_expr (op2->value.character.length);
- e->ts.cl = gfc_new_charlen (gfc_current_ns);
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
if (!e1 || !e2)
return;
- e->ts.cl->length = gfc_add (e1, e2);
- e->ts.cl->length->ts.type = BT_INTEGER;
- e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
- gfc_simplify_expr (e->ts.cl->length, 0);
- gfc_resolve_expr (e->ts.cl->length);
+ e->ts.u.cl->length = gfc_add (e1, e2);
+ e->ts.u.cl->length->ts.type = BT_INTEGER;
+ e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
+ gfc_simplify_expr (e->ts.u.cl->length, 0);
+ gfc_resolve_expr (e->ts.u.cl->length);
return;
}
gfc_resolve_character_array_constructor (e);
case EXPR_SUBSTRING:
- if (!e->ts.cl && e->ref)
+ if (!e->ts.u.cl && e->ref)
gfc_resolve_substring_charlen (e);
default:
- if (!e->ts.cl)
- e->ts.cl = gfc_new_charlen (gfc_current_ns);
+ if (!e->ts.u.cl)
+ e->ts.u.cl = gfc_new_charlen (gfc_current_ns);
break;
}
return FAILURE;
gcc_assert (base->ts.type == BT_DERIVED);
- if (base->ts.derived->attr.abstract)
+ if (base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
- " ABSTRACT type '%s'", &e->where, base->ts.derived->name);
+ " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
return FAILURE;
}
expression_rank (e);
}
- if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
+ if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
&& e->ref->type != REF_SUBSTRING)
gfc_resolve_substring_charlen (e);
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
}
- if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
+ if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
return t;
for (c = sym->components; c; c = c->next)
{
- if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
+ if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
return 1;
}
{
/* Check that transferred derived type doesn't contain POINTER
components. */
- if (ts->derived->attr.pointer_comp)
+ if (ts->u.derived->attr.pointer_comp)
{
gfc_error ("Data transfer element at %L cannot have "
"POINTER components", &code->loc);
return;
}
- if (ts->derived->attr.alloc_comp)
+ if (ts->u.derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have "
"ALLOCATABLE components", &code->loc);
return;
}
- if (derived_inaccessible (ts->derived))
+ if (derived_inaccessible (ts->u.derived))
{
gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc);
and rhs is the same symbol as the lhs. */
if (rhs->expr_type == EXPR_VARIABLE
&& rhs->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer (rhs->symtree->n.sym->ts.derived)
+ && has_default_initializer (rhs->symtree->n.sym->ts.u.derived)
&& (lhs->symtree->n.sym == rhs->symtree->n.sym))
code->ext.actual->next->expr = gfc_get_parentheses (rhs);
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
- if (lhs->ts.cl != NULL
- && lhs->ts.cl->length != NULL
- && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
- llen = mpz_get_si (lhs->ts.cl->length->value.integer);
+ if (lhs->ts.u.cl != NULL
+ && lhs->ts.u.cl->length != NULL
+ && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
if (rhs->expr_type == EXPR_CONSTANT)
rlen = rhs->value.character.length;
- else if (rhs->ts.cl != NULL
- && rhs->ts.cl->length != NULL
- && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
- rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
+ else if (rhs->ts.u.cl != NULL
+ && rhs->ts.u.cl->length != NULL
+ && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
if (rlen && llen && rlen > llen)
gfc_warning_now ("CHARACTER expression will be truncated "
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
- && lhs->ts.derived->attr.pointer_comp
+ && lhs->ts.u.derived->attr.pointer_comp
&& gfc_impure_variable (rhs->symtree->n.sym))
{
gfc_error ("The impure variable at %L is assigned to "
if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
return;
- if (sym->ts.type == BT_DERIVED && sym->ts.derived)
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
init = gfc_default_initializer (&sym->ts);
if (init == NULL)
/* 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.cl->length
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- char_len = mpz_get_si (sym->ts.cl->length->value.integer);
+ 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++)
associated by the presence of another class I symbol in the same
namespace. 14.6.1.3 of the standard and the discussion on
comp.lang.fortran. */
- if (sym->ns != sym->ts.derived->ns
+ if (sym->ns != sym->ts.u.derived->ns
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_symbol *s;
- gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
+ gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
"because it is blocked by an incompatible object "
"of the same name declared at %L",
- sym->ts.derived->name, &sym->declared_at,
+ sym->ts.u.derived->name, &sym->declared_at,
&s->declared_at);
return FAILURE;
}
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable
- && has_default_initializer (sym->ts.derived))
+ && has_default_initializer (sym->ts.u.derived))
{
gfc_error("Object '%s' at %L must have the SAVE attribute for "
"default initialization of a component",
if (sym->ts.is_class)
{
/* C502. */
- if (!type_is_extensible (sym->ts.derived))
+ if (!type_is_extensible (sym->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
- sym->ts.derived->name, sym->name, &sym->declared_at);
+ sym->ts.u.derived->name, sym->name, &sym->declared_at);
return FAILURE;
}
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
- e = sym->ts.cl->length;
+ e = sym->ts.u.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result)
{
gfc_error ("Entity with assumed character length at %L must be a "
if (sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->ts.u.cl;
if (cl && cl->length && gfc_is_constant_expr (cl->length)
&& resolve_charlen (cl) == FAILURE)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
- && !arg->sym->ts.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access)
+ && !arg->sym->ts.u.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
+ arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
"PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L",
== FAILURE)
{
/* Stop this message from recurring. */
- arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
- && !arg->sym->ts.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access)
+ && !arg->sym->ts.u.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
+ arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
gfc_typename (&arg->sym->ts)) == FAILURE)
{
/* Stop this message from recurring. */
- arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
- && !arg->sym->ts.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access)
+ && !arg->sym->ts.u.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
+ arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
gfc_typename (&arg->sym->ts)) == FAILURE)
{
/* Stop this message from recurring. */
- arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
&& sym->ts.type == BT_CHARACTER
- && sym->ts.cl && sym->ts.cl->length == NULL)
+ && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|| (sym->attr.recursive) || (sym->attr.pure))
arg = list->proc_sym->formal->sym;
/* This argument must be of our type. */
- if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
+ if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
{
gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
&arg->declared_at, derived->name);
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.derived != resolve_bindings_derived)
+ || me_arg->ts.u.derived != resolve_bindings_derived)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived-type '%s'", me_arg->name, proc->name,
}
}
/* Copy char length. */
- if (ifc->ts.cl)
+ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- c->ts.cl = gfc_new_charlen (sym->ns);
- c->ts.cl->resolved = ifc->ts.cl->resolved;
- c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
- /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/
+ c->ts.u.cl = gfc_new_charlen (sym->ns);
+ c->ts.u.cl->resolved = ifc->ts.u.cl->resolved;
+ c->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length);
+ /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
}
}
else if (c->ts.interface->name[0] != '\0')
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.derived != sym)
+ || me_arg->ts.u.derived != sym)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
if (c->ts.type == BT_CHARACTER)
{
- if (c->ts.cl->length == NULL
- || (resolve_charlen (c->ts.cl) == FAILURE)
- || !gfc_is_constant_expr (c->ts.cl->length))
+ if (c->ts.u.cl->length == NULL
+ || (resolve_charlen (c->ts.u.cl) == FAILURE)
+ || !gfc_is_constant_expr (c->ts.u.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
"be a constant specification expression at %L",
c->name,
- c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
+ c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
- && !is_sym_host_assoc (c->ts.derived, sym->ns)
- && !c->ts.derived->attr.use_assoc
- && !gfc_check_access (c->ts.derived->attr.access,
- c->ts.derived->ns->default_access)
+ && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
+ && !c->ts.u.derived->attr.use_assoc
+ && !gfc_check_access (c->ts.u.derived->attr.access,
+ c->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
"is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name,
if (sym->attr.sequence)
{
- if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
{
gfc_error ("Component %s of SEQUENCE type declared at %L does "
"not have the SEQUENCE attribute",
- c->ts.derived->name, &sym->declared_at);
+ c->ts.u.derived->name, &sym->declared_at);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED && c->attr.pointer
- && c->ts.derived->components == NULL
- && !c->ts.derived->attr.zero_comp)
+ && c->ts.u.derived->components == NULL
+ && !c->ts.u.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
derived type list; even in formal namespaces, where derived type
pointer components might not have been declared. */
if (c->ts.type == BT_DERIVED
- && c->ts.derived
- && c->ts.derived->components
+ && c->ts.u.derived
+ && c->ts.u.derived->components
&& c->attr.pointer
- && sym != c->ts.derived)
- add_dt_to_dt_list (c->ts.derived);
+ && sym != c->ts.u.derived)
+ add_dt_to_dt_list (c->ts.u.derived);
if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
|| c->as == NULL)
/* Types with private components that came here by USE-association. */
if (nl->sym->ts.type == BT_DERIVED
- && derived_inaccessible (nl->sym->ts.derived))
+ && derived_inaccessible (nl->sym->ts.u.derived))
{
gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
"components and cannot be member of namelist '%s' at %L",
/* Types with private components that are defined in the same module. */
if (nl->sym->ts.type == BT_DERIVED
- && !is_sym_host_assoc (nl->sym->ts.derived, sym->ns)
- && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
+ && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
+ && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
? ACCESS_PRIVATE : ACCESS_UNKNOWN,
nl->sym->ns->default_access))
{
if (nl->sym->ts.type != BT_DERIVED)
continue;
- if (nl->sym->ts.derived->attr.alloc_comp)
+ if (nl->sym->ts.u.derived->attr.alloc_comp)
{
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
"have ALLOCATABLE components",
return FAILURE;
}
- if (nl->sym->ts.derived->attr.pointer_comp)
+ if (nl->sym->ts.u.derived->attr.pointer_comp)
{
gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
"have POINTER components",
}
}
/* Copy char length. */
- if (ifc->ts.cl)
+ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- sym->ts.cl = gfc_new_charlen (sym->ns);
- sym->ts.cl->resolved = ifc->ts.cl->resolved;
- sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
- gfc_expr_replace_symbols (sym->ts.cl->length, sym);
+ sym->ts.u.cl = gfc_new_charlen (sym->ns);
+ sym->ts.u.cl->resolved = ifc->ts.u.cl->resolved;
+ sym->ts.u.cl->length = gfc_copy_expr (ifc->ts.u.cl->length);
+ gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
}
}
else if (sym->ts.interface->name[0] != '\0')
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Character dummy variable '%s' at %L with VALUE "
/* If type() declaration, we need to verify that the components
of the given type are all C interoperable, etc. */
if (sym->ts.type == BT_DERIVED &&
- sym->ts.derived->attr.is_c_interop != 1)
+ sym->ts.u.derived->attr.is_c_interop != 1)
{
/* Make sure the user marked the derived type as BIND(C). If
not, call the verify routine. This could print an error
for the derived type more than once if multiple variables
of that type are declared. */
- if (sym->ts.derived->attr.is_bind_c != 1)
- verify_bind_c_derived_type (sym->ts.derived);
+ if (sym->ts.u.derived->attr.is_bind_c != 1)
+ verify_bind_c_derived_type (sym->ts.u.derived);
t = FAILURE;
}
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
- && !sym->ts.derived->attr.zero_comp)
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
+ && !sym->ts.u.derived->attr.zero_comp)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
- &sym->declared_at, sym->ts.derived->name);
+ &sym->declared_at, sym->ts.u.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
}
derived type is visible in the symbol's namespace, if it is a
module function and is not PRIVATE. */
if (sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.use_assoc
+ && sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
{
gfc_symbol *ds;
- if (resolve_fl_derived (sym->ts.derived) == FAILURE)
+ if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
return;
- gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
+ gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
if (!ds && sym->attr.function
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{
symtree = gfc_new_symtree (&sym->ns->sym_root,
- sym->ts.derived->name);
- symtree->n.sym = sym->ts.derived;
- sym->ts.derived->refs++;
+ sym->ts.u.derived->name);
+ symtree->n.sym = sym->ts.u.derived;
+ sym->ts.u.derived->refs++;
}
}
161 in 95-006r3. */
if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
- && !sym->ts.derived->attr.use_assoc
+ && !sym->ts.u.derived->attr.use_assoc
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
- && !gfc_check_access (sym->ts.derived->attr.access,
- sym->ts.derived->ns->default_access)
+ && !gfc_check_access (sym->ts.u.derived->attr.access,
+ sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
: "variable", sym->name, &sym->declared_at,
- sym->ts.derived->name) == FAILURE)
+ sym->ts.u.derived->name) == FAILURE)
return;
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
&& sym->as
&& sym->as->type == AS_ASSUMED_SIZE)
{
- for (c = sym->ts.derived->components; c; c = c->next)
+ for (c = sym->ts.u.derived->components; c; c = c->next)
{
if (c->initializer)
{
{
case BT_DERIVED:
- if (ts.derived->components == NULL)
+ if (ts.u.derived->components == NULL)
return SEQ_NONDEFAULT;
- result = sequence_type (ts.derived->components->ts);
- for (c = ts.derived->components->next; c; c = c->next)
+ result = sequence_type (ts.u.derived->components->ts);
+ for (c = ts.u.derived->components->next; c; c = c->next)
if (sequence_type (c->ts) != result)
return SEQ_MIXED;
static gfc_try
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
{
- gfc_symbol *d;
gfc_component *c = derived->components;
if (!derived)
return FAILURE;
}
- if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
+ if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
{
gfc_error ("Derived type variable '%s' at %L with default "
"initialization cannot be in EQUIVALENCE with a variable "
for (; c ; c = c->next)
{
- d = c->ts.derived;
- if (d
- && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
+ if (c->ts.type == BT_DERIVED
+ && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
return FAILURE;
/* Shall not be an object of sequence derived type containing a pointer
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
- gfc_symbol *derived;
gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
if (start == NULL)
start = gfc_int_expr (1);
ref->u.ss.start = start;
- if (end == NULL && e->ts.cl)
- end = gfc_copy_expr (e->ts.cl->length);
+ if (end == NULL && e->ts.u.cl)
+ end = gfc_copy_expr (e->ts.u.cl->length);
ref->u.ss.end = end;
- ref->u.ss.length = e->ts.cl;
- e->ts.cl = NULL;
+ ref->u.ss.length = e->ts.u.cl;
+ e->ts.u.cl = NULL;
}
ref = ref->next;
gfc_free (mem);
continue;
}
- derived = e->ts.derived;
- if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
+ if (e->ts.type == BT_DERIVED
+ && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
continue;
/* Check that the types correspond correctly:
sym->attr.untyped = 1;
}
- if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
+ if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
&& !sym->attr.contained
- && !gfc_check_access (sym->ts.derived->attr.access,
- sym->ts.derived->ns->default_access)
+ && !gfc_check_access (sym->ts.u.derived->attr.access,
+ sym->ts.u.derived->ns->default_access)
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
"%L of PRIVATE type '%s'", sym->name,
- &sym->declared_at, sym->ts.derived->name);
+ &sym->declared_at, sym->ts.u.derived->name);
}
if (ns->entries)
}
if (sym->ts.type == BT_CHARACTER
- && !(sym->ts.cl && sym->ts.cl->length)
- && !(sym->result && sym->result->ts.cl
- && sym->result->ts.cl->length))
+ && !(sym->ts.u.cl && sym->ts.u.cl->length)
+ && !(sym->result && sym->result->ts.u.cl
+ && sym->result->ts.u.cl->length))
{
gfc_error ("User operator procedure '%s' at %L cannot be assumed "
"character length", sym->name, &where);
}
}
- if (e->ts.cl != NULL && e->ts.cl->length != NULL
- && e->ts.cl->length->expr_type == EXPR_CONSTANT
- && e->ts.cl->length->ts.type == BT_INTEGER)
+ if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && e->ts.u.cl->length->ts.type == BT_INTEGER)
{
result = gfc_constant_result (BT_INTEGER, k, &e->where);
- mpz_set (result->value.integer, e->ts.cl->length->value.integer);
+ mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
if (gfc_range_check (result) == ARITH_OK)
return result;
else
gfc_array_size (result, &result->shape[0]);
if (array->ts.type == BT_CHARACTER)
- result->ts.cl = array->ts.cl;
+ result->ts.u.cl = array->ts.u.cl;
return result;
}
}
/* If we don't know the character length, we can do no more. */
- if (e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- len = mpz_get_si (e->ts.cl->length->value.integer);
+ len = mpz_get_si (e->ts.u.cl->length->value.integer);
have_length = true;
}
else if (e->expr_type == EXPR_CONSTANT
- && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
{
len = e->value.character.length;
}
if (have_length)
{
mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
- e->ts.cl->length->value.integer);
+ e->ts.u.cl->length->value.integer);
}
else
{
return NULL;
if (len ||
- (e->ts.cl->length &&
- mpz_sgn (e->ts.cl->length->value.integer)) != 0)
+ (e->ts.u.cl->length &&
+ mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL);
return NULL;
if (source->ts.type == BT_CHARACTER)
- result->ts.cl = source->ts.cl;
+ result->ts.u.cl = source->ts.u.cl;
return result;
}
mpz_set (result->shape[1], matrix->shape[0]);
if (matrix->ts.type == BT_CHARACTER)
- result->ts.cl = matrix->ts.cl;
+ result->ts.u.cl = matrix->ts.u.cl;
matrix_rows = mpz_get_si (matrix->shape[0]);
matrix_ctor = matrix->value.constructor;
result->shape = gfc_copy_shape (mask->shape, mask->rank);
if (vector->ts.type == BT_CHARACTER)
- result->ts.cl = vector->ts.cl;
+ result->ts.u.cl = vector->ts.u.cl;
vector_ctor = vector->value.constructor;
mask_ctor = mask->value.constructor;
result->shape = gfc_copy_shape (e->shape, e->rank);
result->where = e->where;
result->rank = e->rank;
- result->ts.cl = e->ts.cl;
+ result->ts.u.cl = e->ts.u.cl;
return result;
}
sym->ts = *ts;
sym->attr.implicit_type = 1;
- if (ts->cl)
+ if (ts->type == BT_CHARACTER && ts->u.cl)
{
- sym->ts.cl = gfc_get_charlen ();
- *sym->ts.cl = *ts->cl;
+ sym->ts.u.cl = gfc_get_charlen ();
+ *sym->ts.u.cl = *ts->u.cl;
}
if (sym->attr.is_bind_c == 1)
}
if (sym->attr.extension
- && gfc_find_component (sym->components->ts.derived, name, true, true))
+ && gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
gfc_error ("Component '%s' at %C already in the parent type "
- "at %L", name, &sym->components->ts.derived->declared_at);
+ "at %L", name, &sym->components->ts.u.derived->declared_at);
return FAILURE;
}
return;
sym = st->n.sym;
- if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
- sym->ts.derived = to;
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
+ sym->ts.u.derived = to;
switch_types (st->left, from, to);
switch_types (st->right, from, to);
for (i = 0; i < GFC_LETTERS; i++)
{
t = &sym->ns->default_type[i];
- if (t->derived == sym)
- t->derived = s;
+ if (t->u.derived == sym)
+ t->u.derived = s;
}
st = gfc_find_symtree (sym->ns->sym_root, sym->name);
&& sym->attr.extension
&& sym->components->ts.type == BT_DERIVED)
{
- p = gfc_find_component (sym->components->ts.derived, name,
+ p = gfc_find_component (sym->components->ts.u.derived, name,
noaccess, silent);
/* Do not overwrite the error. */
if (p == NULL)
return true;
/* Check for non-constant length character variables. */
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && !gfc_is_constant_expr (sym->ts.cl->length))
+ && sym->ts.u.cl
+ && !gfc_is_constant_expr (sym->ts.u.cl->length))
return true;
return false;
}
/* BIND(C) derived types must have interoperable components. */
if (curr_comp->ts.type == BT_DERIVED
- && curr_comp->ts.derived->ts.is_iso_c != 1
- && curr_comp->ts.derived != derived_sym)
+ && curr_comp->ts.u.derived->ts.is_iso_c != 1
+ && curr_comp->ts.u.derived != derived_sym)
{
/* This should be allowed; the draft says a derived-type can not
have type parameters if it is has the BIND attribute. Type
parameters seem to be for making parameterized derived types.
There's no need to verify the type if it is c_ptr/c_funptr. */
- retval = verify_bind_c_derived_type (curr_comp->ts.derived);
+ retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
}
else
{
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.u.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
c_funptr and they're trying to use one of the procedures
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
- tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
/* Create a constructor with no expr, that way we can recognize if the user
tries to call the structure constructor for one of the iso_c_binding
derived types during resolution (resolve_structure_cons). */
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
- param_sym->ts.derived = c_ptr_sym;
+ param_sym->ts.u.derived = c_ptr_sym;
param_sym->module = gfc_get_string (module_name);
/* Make new formal arg. */
formal_arg->sym->attr.dummy = 1;
if (formal_arg->sym->ts.type == BT_CHARACTER)
- formal_arg->sym->ts.cl = gfc_new_charlen (gfc_current_ns);
+ formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns);
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
tmp_sym->value->value.character.string[0]
= (gfc_char_t) c_interop_kinds_table[s].value;
tmp_sym->value->value.character.string[1] = '\0';
- tmp_sym->ts.cl = gfc_get_charlen ();
- tmp_sym->ts.cl->length = gfc_int_expr (1);
+ tmp_sym->ts.u.cl = gfc_get_charlen ();
+ tmp_sym->ts.u.cl->length = gfc_int_expr (1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
tmp_sym->attr.referenced = 1;
- tmp_sym->ts.derived = tmp_sym;
+ tmp_sym->ts.u.derived = tmp_sym;
/* Add the symbol created for the derived type to the current ns. */
dt_list_ptr = &(gfc_derived_types);
C address of. */
tmp_sym->ts.type = BT_DERIVED;
if (s == ISOCBINDING_LOC)
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ if (tmp_sym->ts.u.derived == NULL)
{
/* Create the necessary derived type so we can continue
processing the file. */
(const char *)(s == ISOCBINDING_FUNLOC
? "_gfortran_iso_c_binding_c_funptr"
: "_gfortran_iso_c_binding_c_ptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
gcc_assert (derived->components);
gcc_assert (derived->components->ts.type == BT_DERIVED);
- gcc_assert (derived->components->ts.derived);
+ gcc_assert (derived->components->ts.u.derived);
- return derived->components->ts.derived;
+ return derived->components->ts.u.derived;
}
type = gfc_typenode_for_spec (&source->ts);
ctr = source->value.constructor;
- cmp = source->ts.derived->components;
+ cmp = source->ts.u.derived->components;
for (;ctr; ctr = ctr->next, cmp = cmp->next)
{
gcc_assert (cmp);
{
int i;
- if (result->ts.cl && result->ts.cl->length)
+ if (result->ts.u.cl && result->ts.u.cl->length)
result->value.character.length =
- (int) mpz_get_ui (result->ts.cl->length->value.integer);
+ (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
gcc_assert (buffer_size >= size_character (result->value.character.length,
result->ts.kind));
result->expr_type = EXPR_STRUCTURE;
type = gfc_typenode_for_spec (&result->ts);
- cmp = result->ts.derived->components;
+ cmp = result->ts.u.derived->components;
/* Run through the derived type components. */
for (;cmp; cmp = cmp->next)
if (e->ts.type == BT_DERIVED)
{
ctr = e->value.constructor;
- cmp = e->ts.derived->components;
+ cmp = e->ts.u.derived->components;
for (;ctr; ctr = ctr->next, cmp = cmp->next)
{
gcc_assert (cmp && cmp->backend_decl);
}
}
- *len = ts->cl->backend_decl;
+ *len = ts->u.cl->backend_decl;
}
if (*len && INTEGER_CST_P (*len))
return;
- if (!e->ref && e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
/* This is easy. */
- gfc_conv_const_charlen (e->ts.cl);
- *len = e->ts.cl->backend_decl;
+ gfc_conv_const_charlen (e->ts.u.cl);
+ *len = e->ts.u.cl->backend_decl;
}
else
{
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (block, &se.post);
- e->ts.cl->backend_decl = *len;
+ e->ts.u.cl->backend_decl = *len;
}
}
/* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
typespec was given for the array constructor. */
- typespec_chararray_ctor = (ss->expr->ts.cl
- && ss->expr->ts.cl->length_from_typespec);
+ typespec_chararray_ctor = (ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length_from_typespec);
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
/* get_array_ctor_strlen walks the elements of the constructor, if a
typespec was given, we already know the string length and want the one
specified there. */
- if (typespec_chararray_ctor && ss->expr->ts.cl->length
- && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
+ && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
{
gfc_se length_se;
const_string = false;
gfc_init_se (&length_se, NULL);
- gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
+ gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
gfc_charlen_type_node);
ss->string_length = length_se.expr;
gfc_add_block_to_block (&loop->pre, &length_se.pre);
and not end up here. */
gcc_assert (ss->string_length);
- ss->expr->ts.cl->backend_decl = ss->string_length;
+ ss->expr->ts.u.cl->backend_decl = ss->string_length;
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
case GFC_SS_CONSTRUCTOR:
if (ss->expr->ts.type == BT_CHARACTER
&& ss->string_length == NULL
- && ss->expr->ts.cl
- && ss->expr->ts.cl->length)
+ && ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
+ gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
gfc_charlen_type_node);
ss->string_length = se.expr;
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp)
+ && expr->ts.u.derived->attr.alloc_comp)
{
- tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
ref->u.ar.as->rank);
gfc_add_expr_to_block (&se->pre, tmp);
}
/* Evaluate character string length. */
if (sym->ts.type == BT_CHARACTER
- && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
gcc_assert (!sym->module);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, NULL, &block);
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
checkparm = (sym->as->type == AS_EXPLICIT
&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
gfc_actual_arglist *arg;
gfc_se tse;
- if (expr->ts.cl->length
- && gfc_is_constant_expr (expr->ts.cl->length))
+ if (expr->ts.u.cl->length
+ && gfc_is_constant_expr (expr->ts.u.cl->length))
{
- if (!expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ if (!expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
return;
}
case EXPR_OP:
get_array_charlen (expr->value.op.op1, se);
- /* For parentheses the expression ts.cl is identical. */
+ /* For parentheses the expression ts.u.cl is identical. */
if (expr->value.op.op == INTRINSIC_PARENTHESES)
return;
- expr->ts.cl->backend_decl =
+ expr->ts.u.cl->backend_decl =
gfc_create_var (gfc_charlen_type_node, "sln");
if (expr->value.op.op2)
/* Add the string lengths and assign them to the expression
string length backend declaration. */
- gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
- expr->value.op.op1->ts.cl->backend_decl,
- expr->value.op.op2->ts.cl->backend_decl));
+ expr->value.op.op1->ts.u.cl->backend_decl,
+ expr->value.op.op2->ts.u.cl->backend_decl));
}
else
- gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
- expr->value.op.op1->ts.cl->backend_decl);
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+ expr->value.op.op1->ts.u.cl->backend_decl);
break;
case EXPR_FUNCTION:
if (expr->value.function.esym == NULL
- || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
break;
}
gfc_init_se (&tse, NULL);
/* Build the expression for the character length and convert it. */
- gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+ gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &tse.pre);
gfc_add_block_to_block (&se->post, &tse.post);
tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
build_int_cst (gfc_charlen_type_node, 0));
- expr->ts.cl->backend_decl = tse.expr;
+ expr->ts.u.cl->backend_decl = tse.expr;
gfc_free_interface_mapping (&mapping);
break;
default:
- gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
break;
}
}
/* Elemental function. */
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
get_array_charlen (expr, se);
info = NULL;
loop.temp_ss->next = gfc_ss_terminator;
if (expr->ts.type == BT_CHARACTER
- && !expr->ts.cl->backend_decl)
+ && !expr->ts.u.cl->backend_decl)
get_array_charlen (expr, se);
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
loop.temp_ss->string_length = NULL;
if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
{
get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
- expr->ts.cl->backend_decl = tmp;
+ expr->ts.u.cl->backend_decl = tmp;
se->string_length = tmp;
}
tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
&& !sym->attr.allocatable)
{
/* Deallocate the allocatable components of structures that are
not variable. */
if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp
+ && expr->ts.u.derived->attr.alloc_comp
&& expr->expr_type != EXPR_VARIABLE)
{
tmp = build_fold_indirect_ref_loc (input_location,
se->expr);
- tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
gfc_add_expr_to_block (&se->post, tmp);
}
for (c = der_type->components; c; c = c->next)
{
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
- && c->ts.derived->attr.alloc_comp;
+ && c->ts.u.derived->attr.alloc_comp;
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
comp = fold_build3 (COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
comp = fold_build3 (COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
gfc_add_modify (&fnblock, dcmp, tmp);
- tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
bool sym_has_alloc_comp;
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.derived->attr.alloc_comp;
+ && sym->ts.u.derived->attr.alloc_comp;
/* Make sure the frontend gets these right. */
if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
|| TREE_CODE (sym->backend_decl) == PARM_DECL);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
if (!sym->attr.save)
{
rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
gfc_add_expr_to_block (&fnblock, tmp);
if (sym->value)
{
{
int rank;
rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
+ tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
/* Make sure we've got the character length. */
if (sym->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
/* Create the segment_info and fill it in. */
s = (segment_info *) gfc_getmem (sizeof (segment_info));
case AR_ELEMENT:
n = element_number (&reference->u.ar);
if (element_type->type == BT_CHARACTER)
- gfc_conv_const_charlen (element_type->cl);
+ gfc_conv_const_charlen (element_type->u.cl);
element_size =
int_size_in_bytes (gfc_typenode_for_spec (element_type));
offset += n * element_size;
/* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
so, they expr_type will not yet be an EXPR_CONSTANT. We need to make
it so here. */
- if (expr->ts.type == BT_DERIVED && expr->ts.derived
- && expr->ts.derived->attr.is_iso_c)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->attr.is_iso_c)
{
if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
|| expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
/* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
- || INTEGER_CST_P (sym->ts.cl->backend_decl);
+ || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
static tree
gfc_create_string_length (gfc_symbol * sym)
{
- gcc_assert (sym->ts.cl);
- gfc_conv_const_charlen (sym->ts.cl);
+ gcc_assert (sym->ts.u.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
{
tree length;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
if (sym->ns->proc_name->tlink != NULL)
gfc_defer_symbol_init (sym);
- sym->ts.cl->backend_decl = length;
+ sym->ts.u.cl->backend_decl = length;
}
- gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
- return sym->ts.cl->backend_decl;
+ gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
+ return sym->ts.u.cl->backend_decl;
}
/* If a variable is assigned a label, we add another two auxiliary
/* Create a character length variable. */
if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
{
if (s && s->backend_decl)
{
if (sym->ts.type == BT_CHARACTER)
- sym->ts.cl->backend_decl = s->ts.cl->backend_decl;
+ sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
return s->backend_decl;
}
}
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
- if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
gfc_defer_symbol_init (sym);
/* This applies a derived type default initializer. */
else if (sym->ts.type == BT_DERIVED
PARM_DECL,
get_identifier (".__result"),
len_type);
- if (!sym->ts.cl->length)
+ if (!sym->ts.u.cl->length)
{
- sym->ts.cl->backend_decl = length;
+ sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length);
- if (sym->ts.cl->backend_decl == NULL
- || sym->ts.cl->backend_decl == length)
+ if (sym->ts.u.cl->backend_decl == NULL
+ || sym->ts.u.cl->backend_decl == length)
{
gfc_symbol *arg;
tree backend_decl;
- if (sym->ts.cl->backend_decl == NULL)
+ if (sym->ts.u.cl->backend_decl == NULL)
{
tree len = build_decl (input_location,
VAR_DECL,
gfc_charlen_type_node);
DECL_ARTIFICIAL (len) = 1;
TREE_USED (len) = 1;
- sym->ts.cl->backend_decl = len;
+ sym->ts.u.cl->backend_decl = len;
}
/* Make sure PARM_DECL type doesn't point to incomplete type. */
gfc_finish_decl (length);
/* Remember the passed value. */
- if (f->sym->ts.cl->passed_length != NULL)
+ if (f->sym->ts.u.cl->passed_length != NULL)
{
/* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise
cl->passed_length gets overwritten. */
gfc_charlen *cl, *cl2;
- cl = f->sym->ts.cl;
- f->sym->ts.cl = gfc_get_charlen();
- f->sym->ts.cl->length = cl->length;
- f->sym->ts.cl->backend_decl = cl->backend_decl;
- f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
- f->sym->ts.cl->resolved = cl->resolved;
- cl2 = f->sym->ts.cl->next;
- f->sym->ts.cl->next = cl;
+ cl = f->sym->ts.u.cl;
+ f->sym->ts.u.cl = gfc_get_charlen();
+ f->sym->ts.u.cl->length = cl->length;
+ f->sym->ts.u.cl->backend_decl = cl->backend_decl;
+ f->sym->ts.u.cl->length_from_typespec = cl->length_from_typespec;
+ f->sym->ts.u.cl->resolved = cl->resolved;
+ cl2 = f->sym->ts.u.cl->next;
+ f->sym->ts.u.cl->next = cl;
cl->next = cl2;
}
- f->sym->ts.cl->passed_length = length;
+ f->sym->ts.u.cl->passed_length = length;
/* Use the passed value for assumed length variables. */
- if (!f->sym->ts.cl->length)
+ if (!f->sym->ts.u.cl->length)
{
TREE_USED (length) = 1;
- gcc_assert (!f->sym->ts.cl->backend_decl);
- f->sym->ts.cl->backend_decl = length;
+ gcc_assert (!f->sym->ts.u.cl->backend_decl);
+ f->sym->ts.u.cl->backend_decl = length;
}
hidden_typelist = TREE_CHAIN (hidden_typelist);
- if (f->sym->ts.cl->backend_decl == NULL
- || f->sym->ts.cl->backend_decl == length)
+ if (f->sym->ts.u.cl->backend_decl == NULL
+ || f->sym->ts.u.cl->backend_decl == length)
{
- if (f->sym->ts.cl->backend_decl == NULL)
+ if (f->sym->ts.u.cl->backend_decl == NULL)
gfc_create_string_length (f->sym);
/* Make sure PARM_DECL type doesn't point to incomplete type. */
args);
if (formal->sym->ts.type == BT_CHARACTER)
{
- tmp = thunk_formal->sym->ts.cl->backend_decl;
+ tmp = thunk_formal->sym->ts.u.cl->backend_decl;
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
{
formal->sym->backend_decl = NULL_TREE;
if (formal->sym->ts.type == BT_CHARACTER)
- formal->sym->ts.cl->backend_decl = NULL_TREE;
+ formal->sym->ts.u.cl->backend_decl = NULL_TREE;
}
if (thunk_sym->attr.function)
{
if (thunk_sym->ts.type == BT_CHARACTER)
- thunk_sym->ts.cl->backend_decl = NULL_TREE;
+ thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
if (thunk_sym->result->ts.type == BT_CHARACTER)
- thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+ thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
}
}
if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->backend_decl == NULL_TREE)
+ if (sym->ts.u.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
gfc_add_decl_to_function (length);
tree tmp;
gcc_assert (sym->backend_decl);
- gcc_assert (sym->ts.cl && sym->ts.cl->length);
+ gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (sym->ts.cl, NULL, &body);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.derived->attr.alloc_comp)
+ if (f->sym->ts.u.derived->attr.alloc_comp)
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
f->sym->backend_decl,
f->sym->as ? f->sym->as->rank : 0);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (!f->sym->ts.derived->attr.alloc_comp
+ if (!f->sym->ts.u.derived->attr.alloc_comp
&& f->sym->value)
body = gfc_init_default_dt (f->sym, body);
}
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
- && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
- if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
fnbody);
}
else
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.derived->attr.alloc_comp;
+ && sym->ts.u.derived->attr.alloc_comp;
if (sym->attr.dimension)
{
switch (sym->as->type)
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
- fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
+ fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
{
if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
- gcc_assert (f->sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+ gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
+ if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (f->sym, &body);
}
}
if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
{
- gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+ gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (proc_sym, &body);
}
{
tree length;
- length = sym->ts.cl->backend_decl;
+ length = sym->ts.u.cl->backend_decl;
if (!INTEGER_CST_P (length))
{
pushdecl (length);
case BT_DERIVED:
if (expr->expr_type != EXPR_STRUCTURE)
return false;
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
if (sym->ts.type == BT_CHARACTER)
{
- gfc_conv_const_charlen (sym->ts.cl);
- if (sym->ts.cl->backend_decl == NULL
- || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
+ gfc_conv_const_charlen (sym->ts.u.cl);
+ if (sym->ts.u.cl->backend_decl == NULL
+ || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
return;
}
- else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
return;
if (sym->as)
int i;
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
- generate_expr_decls (sym, sym->ts.cl->length);
+ && sym->ts.u.cl
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ generate_expr_decls (sym, sym->ts.u.cl->length);
if (sym->as && sym->as->rank)
{
warning if requested. */
if (sym->attr.dummy && !sym->attr.referenced
&& sym->ts.type == BT_CHARACTER
- && sym->ts.cl->backend_decl != NULL
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+ && sym->ts.u.cl->backend_decl != NULL
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
{
sym->attr.referenced = 1;
gfc_get_symbol_decl (sym);
generate the code for nullification and automatic lengths. */
if (!sym->attr.referenced
&& sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
+ && sym->ts.u.derived->attr.alloc_comp
&& !sym->attr.pointer
&& ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
||
const char *message;
fsym = formal->sym;
- cl = fsym->ts.cl;
+ cl = fsym->ts.u.cl;
gcc_assert (cl);
gcc_assert (cl->passed_length != NULL_TREE);
gfc_entry_list *el;
tree backend_decl;
- gfc_conv_const_charlen (ns->proc_name->ts.cl);
- backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+ gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
+ backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
for (el = ns->entries; el; el = el->next)
- el->sym->result->ts.cl->backend_decl = backend_decl;
+ el->sym->result->ts.u.cl->backend_decl = backend_decl;
}
/* Translate COMMON blocks. */
if (result != NULL_TREE && sym->attr.function
&& sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp
+ && sym->ts.u.derived->attr.alloc_comp
&& !sym->attr.pointer)
{
rank = sym->as ? sym->as->rank : 0;
- tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
+ tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
gfc_add_expr_to_block (&block, tmp2);
}
length = NULL; /* To silence compiler warning. */
- if (is_subref_array (e) && e->ts.cl->length)
+ if (is_subref_array (e) && e->ts.u.cl->length)
{
gfc_se tmpse;
gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
- e->ts.cl->backend_decl = tmpse.expr;
+ gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
+ e->ts.u.cl->backend_decl = tmpse.expr;
return tmpse.expr;
}
expression's length could be the length of the character
variable. */
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
- length = e->symtree->n.sym->ts.cl->backend_decl;
+ length = e->symtree->n.sym->ts.u.cl->backend_decl;
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
{
case REF_COMPONENT:
if (r->u.c.component->ts.type == BT_CHARACTER)
- length = r->u.c.component->ts.cl->backend_decl;
+ length = r->u.c.component->ts.u.cl->backend_decl;
break;
case REF_ARRAY:
}
-/* For each character array constructor subexpression without a ts.cl->length,
+/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
case EXPR_ARRAY:
/* We've found what we're looking for. */
- if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
gfc_expr* new_expr;
gcc_assert (e->value.constructor);
if (c->ts.type == BT_CHARACTER)
{
- tmp = c->ts.cl->backend_decl;
+ tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
gcc_assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
/* Otherwise build the reference and call self. */
gfc_conv_component_ref (se, &parent);
- parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.sym = dt->components->ts.u.derived;
parent.u.c.component = c;
conv_parent_component_references (se, &parent);
}
{
/* If the character length of an entry isn't set, get the length from
the master function instead. */
- if (sym->attr.entry && !sym->ts.cl->backend_decl)
- se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
+ if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
+ se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
else
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
gcc_assert (se->string_length);
}
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
if (sym->ts.type == BT_CHARACTER)
{
/* Create a copy of the dummy argument's length. */
- new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
- sm->expr->ts.cl = new_sym->ts.cl;
+ new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
+ sm->expr->ts.u.cl = new_sym->ts.u.cl;
/* If the length is specified as "*", record the length that
the caller is passing. We should use the callee's length
in all other cases. */
- if (!new_sym->ts.cl->length && se)
+ if (!new_sym->ts.u.cl->length && se)
{
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
- new_sym->ts.cl->backend_decl = se->string_length;
+ new_sym->ts.u.cl->backend_decl = se->string_length;
}
}
se->expr);
/* For character(*), use the actual argument's descriptor. */
- else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
for (sym = mapping->syms; sym; sym = sym->next)
if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
- && !sym->new_sym->n.sym->ts.cl->backend_decl)
+ && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
{
- expr = sym->new_sym->n.sym->ts.cl->length;
+ expr = sym->new_sym->n.sym->ts.u.cl->length;
gfc_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (pre, &se.pre);
gfc_add_block_to_block (post, &se.post);
- sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
+ sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
}
}
case GFC_ISYM_LEN:
/* TODO figure out why this condition is necessary. */
if (sym->attr.function
- && (arg1->ts.cl->length == NULL
- || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
- && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
+ && (arg1->ts.u.cl->length == NULL
+ || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
return false;
- new_expr = gfc_copy_expr (arg1->ts.cl->length);
+ new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
break;
case GFC_ISYM_SIZE:
if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
{
- expr->value.function.esym->ts.cl->length
- = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length
+ = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.esym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length);
}
}
return;
/* Copying an expression does not copy its length, so do that here. */
- if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+ if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
{
- expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
- gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+ expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
}
/* Apply the mapping to any references. */
gfc_conv_ss_startstride (&loop);
/* Build an ss for the temporary. */
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
loop.temp_ss->string_length = NULL;
rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
- rse.string_length = expr->ts.cl->backend_decl;
+ rse.string_length = expr->ts.u.cl->backend_decl;
gfc_conv_expr (&lse, expr);
/* Pass the string length to the argument expression. */
if (expr->ts.type == BT_CHARACTER)
- parmse->string_length = expr->ts.cl->backend_decl;
+ parmse->string_length = expr->ts.u.cl->backend_decl;
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
- arg->expr->ts.type = sym->ts.derived->ts.type;
- arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
- arg->expr->ts.kind = sym->ts.derived->ts.kind;
+ arg->expr->ts.type = sym->ts.u.derived->ts.type;
+ arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
+ arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
return 0;
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type
!= EXPR_CONSTANT)
|| (comp && comp->attr.dimension)
|| (!comp && sym->attr.dimension));
&& parmse.string_length == NULL_TREE
&& e->ts.type == BT_PROCEDURE
&& e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL
- && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && e->symtree->n.sym->ts.u.cl->length != NULL
+ && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
- parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+ gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+ parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
}
}
deallocated for non-variable scalars. Non-variable arrays are
dealt with in trans-array.c(gfc_conv_array_parameter). */
if (e && e->ts.type == BT_DERIVED
- && e->ts.derived->attr.alloc_comp
+ && e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
&& (e->expr_type != EXPR_VARIABLE && !e->rank))
{
{
tree local_tmp;
local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+ local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, local_tmp);
}
- tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, tmp);
}
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
else if (ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->length == NULL)
+ if (sym->ts.u.cl->length == NULL)
{
/* Assumed character length results are not allowed by 5.1.1.5 of the
standard and are trapped in resolve.c; except in the case of SPREAD
formal = sym->ns->proc_name->formal;
for (; formal; formal = formal->next)
if (strcmp (formal->sym->name, sym->name) == 0)
- cl.backend_decl = formal->sym->ts.cl->backend_decl;
+ cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
}
else
/* Calculate the length of the returned string. */
gfc_init_se (&parmse, NULL);
if (need_interface_mapping)
- gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+ gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
else
- gfc_conv_expr (&parmse, sym->ts.cl->length);
+ gfc_conv_expr (&parmse, sym->ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
/* Set up a charlen structure for it. */
cl.next = NULL;
cl.length = NULL;
- ts.cl = &cl;
+ ts.u.cl = &cl;
len = cl.backend_decl;
}
else if (ts.type == BT_CHARACTER)
{
/* Pass the string length. */
- type = gfc_get_character_type (ts.kind, ts.cl);
+ type = gfc_get_character_type (ts.kind, ts.u.cl);
type = build_pointer_type (type);
/* Return an address to a char[0:len-1]* temporary for
/* Copy string arguments. */
tree arglen;
- gcc_assert (fsym->ts.cl && fsym->ts.cl->length
- && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
if (sym->ts.type == BT_CHARACTER)
{
- gfc_conv_const_charlen (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
/* Force the expression to the correct length. */
if (!INTEGER_CST_P (se->string_length)
|| tree_int_cst_lt (se->string_length,
- sym->ts.cl->backend_decl))
+ sym->ts.u.cl->backend_decl))
{
- type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+ type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
- gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+ gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
sym->ts.kind, se->string_length, se->expr,
sym->ts.kind);
se->expr = tmp;
}
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
}
/* Restore the original variables. */
used as initialization expressions). If so, we need to modify
the 'expr' to be that for a (void *). */
if (expr != NULL && expr->ts.type == BT_DERIVED
- && expr->ts.is_iso_c && expr->ts.derived)
+ && expr->ts.is_iso_c && expr->ts.u.derived)
{
- gfc_symbol *derived = expr->ts.derived;
+ gfc_symbol *derived = expr->ts.u.derived;
expr = gfc_int_expr (0);
return se.expr;
case BT_CHARACTER:
- return gfc_conv_string_init (ts->cl->backend_decl,expr);
+ return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
default:
gfc_init_se (&se, NULL);
gfc_conv_tmp_array_ref (&lse);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
gfc_conv_expr (&rse, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr);
- if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
- tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
+ if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
+ tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
cm->as->rank);
else
tmp = gfc_duplicate_allocatable (dest, se.expr,
gfc_conv_expr (&se, expr);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
gfc_add_expr_to_block (&block, tmp);
tree tmp;
gfc_start_block (&block);
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!init)
{
/* Create a temporary variable and fill it in. */
- se->expr = gfc_create_var (type, expr->ts.derived->name);
+ se->expr = gfc_create_var (type, expr->ts.u.derived->name);
tmp = gfc_trans_structure_assign (se->expr, expr);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
typespec for the C_PTR and C_FUNPTR symbols, which has already been
updated to be an integer with a kind equal to the size of a (void *). */
- if (expr->ts.type == BT_DERIVED && expr->ts.derived
- && expr->ts.derived->attr.is_iso_c)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->attr.is_iso_c)
{
if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
|| expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
{
/* Update the type/kind of the expression to be what the new
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
- expr->ts.type = expr->ts.derived->ts.type;
- expr->ts.f90_type = expr->ts.derived->ts.f90_type;
- expr->ts.kind = expr->ts.derived->ts.kind;
+ expr->ts.type = expr->ts.u.derived->ts.type;
+ expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.u.derived->ts.kind;
}
}
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+ else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
cond = NULL_TREE;
if (!l_is_temp)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
if (r_is_var)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
same as the lhs. */
if (r_is_var)
{
- tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
+ tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
gfc_add_expr_to_block (&block, tmp);
character lengths are the same. */
if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
{
- if (expr1->ts.cl->length == NULL
- || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (expr1->ts.u.cl->length == NULL
+ || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
- if (expr2->ts.cl->length == NULL
- || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (expr2->ts.u.cl->length == NULL
+ || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpz_cmp (expr1->ts.cl->length->value.integer,
- expr2->ts.cl->length->value.integer) != 0)
+ if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
+ expr2->ts.u.cl->length->value.integer) != 0)
return NULL;
}
to arrays must be done with a deep copy and the rhs temporary
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
- && expr2->ts.derived->attr.alloc_comp
+ && expr2->ts.u.derived->attr.alloc_comp
&& expr2->expr_type != EXPR_VARIABLE
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
if (scalar_to_array)
{
- tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+ tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
}
return false;
case BT_DERIVED:
- return !expr->ts.derived->attr.alloc_comp;
+ return !expr->ts.u.derived->attr.alloc_comp;
default:
break;
&& (sym->result == sym))
decl = gfc_get_fake_result_decl (sym, 0);
- len = sym->ts.cl->backend_decl;
+ len = sym->ts.u.cl->backend_decl;
gcc_assert (len);
break;
}
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
- arg1->expr->ts.cl->backend_decl,
+ arg1->expr->ts.u.cl->backend_decl,
integer_zero_node);
if (ss1 == gfc_ss_terminator)
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, ncopies));
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
/* Generate the code to do the repeat operation:
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
if (ts->type == BT_CHARACTER)
- tmp = ts->cl->backend_decl;
+ tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = build_call_expr_loc (input_location,
tree expr = build_fold_indirect_ref_loc (input_location,
addr_expr);
- for (cmp = ts->derived->components; cmp; cmp = cmp->next)
+ for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
{
char *full_name = nml_full_name (var_name, cmp->name);
transfer_namelist_element (block,
C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
BT_DERIVED (could have been changed by gfc_conv_expr). */
- if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
- || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
+ if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
+ && ts->u.derived != NULL
+ && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
{
/* C_PTR and C_FUNPTR have private components which means they can not
be printed. However, if -std=gnu and not -pedantic, allow
if (gfc_notification_std (GFC_STD_GNU) != SILENT)
{
gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
- ts->derived->name, code != NULL ? &(code->loc) :
+ ts->u.derived->name, code != NULL ? &(code->loc) :
&gfc_current_locus);
return;
}
- ts->type = ts->derived->ts.type;
- ts->kind = ts->derived->ts.kind;
- ts->f90_type = ts->derived->ts.f90_type;
+ ts->type = ts->u.derived->ts.type;
+ ts->kind = ts->u.derived->ts.kind;
+ ts->f90_type = ts->u.derived->ts.f90_type;
}
kind = ts->kind;
expr = build_fold_indirect_ref_loc (input_location,
expr);
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
pointer components. We therefore leave these to their
own devices. */
if (lsym->ts.type == BT_DERIVED
- && lsym->ts.derived->attr.pointer_comp)
+ && lsym->ts.u.derived->attr.pointer_comp)
return need_temp;
new_symtree = NULL;
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
{
- if (!expr1->ts.cl->backend_decl)
+ if (!expr1->ts.u.cl->backend_decl)
{
gfc_se tse;
gfc_init_se (&tse, NULL);
- gfc_conv_expr (&tse, expr1->ts.cl->length);
- expr1->ts.cl->backend_decl = tse.expr;
+ gfc_conv_expr (&tse, expr1->ts.u.cl->length);
+ expr1->ts.u.cl->backend_decl = tse.expr;
}
type = gfc_get_character_type_len (gfc_default_character_kind,
- expr1->ts.cl->backend_decl);
+ expr1->ts.u.cl->backend_decl);
}
else
type = gfc_typenode_for_spec (&expr1->ts);
gfc_add_expr_to_block (&se.pre, tmp);
}
- if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
- tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
- tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
C_FUNPTR to simple variables that get translated to (void *). */
if (spec->f90_type == BT_VOID)
{
- if (spec->derived
- && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ if (spec->u.derived
+ && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
break;
case BT_CHARACTER:
- basetype = gfc_get_character_type (spec->kind, spec->cl);
+ basetype = gfc_get_character_type (spec->kind, spec->u.cl);
break;
case BT_DERIVED:
- basetype = gfc_get_derived_type (spec->derived);
+ basetype = gfc_get_derived_type (spec->u.derived);
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
symbol that was declared of type C_PTR or C_FUNPTR. */
- if (spec->derived->attr.is_iso_c)
+ if (spec->u.derived->attr.is_iso_c)
{
- spec->type = spec->derived->ts.type;
- spec->kind = spec->derived->ts.kind;
- spec->f90_type = spec->derived->ts.f90_type;
+ spec->type = spec->u.derived->ts.type;
+ spec->kind = spec->u.derived->ts.kind;
+ spec->f90_type = spec->u.derived->ts.f90_type;
}
break;
case BT_VOID:
basetype = ptr_type_node;
if (spec->f90_type == BT_VOID)
{
- if (spec->derived
- && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ if (spec->u.derived
+ && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
base type. */
if (sym->ts.type != BT_CHARACTER
|| !(sym->attr.dummy || sym->attr.function)
- || sym->ts.cl->backend_decl)
+ || sym->ts.u.cl->backend_decl)
{
type = gfc_get_nodesc_array_type (type, sym->as,
byref ? PACKED_FULL
to_cm->backend_decl = from_cm->backend_decl;
if ((!from_cm->attr.pointer || from_gsym)
&& from_cm->ts.type == BT_DERIVED)
- gfc_get_derived_type (to_cm->ts.derived);
+ gfc_get_derived_type (to_cm->ts.u.derived);
else if (from_cm->ts.type == BT_CHARACTER)
- to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
+ to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
}
return 1;
if (c->attr.function && !c->attr.dimension)
{
if (c->ts.type == BT_DERIVED)
- t = c->ts.derived->backend_decl;
+ t = c->ts.u.derived->backend_decl;
else
t = gfc_typenode_for_spec (&c->ts);
}
continue;
if ((!c->attr.pointer && !c->attr.proc_pointer)
- || c->ts.derived->backend_decl == NULL)
- c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+ || c->ts.u.derived->backend_decl == NULL)
+ c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
- if (c->ts.derived && c->ts.derived->attr.is_iso_c)
+ if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
{
/* Need to copy the modified ts from the derived type. The
typespec was modified because C_PTR/C_FUNPTR are translated
into (void *) from derived types. */
- c->ts.type = c->ts.derived->ts.type;
- c->ts.kind = c->ts.derived->ts.kind;
- c->ts.f90_type = c->ts.derived->ts.f90_type;
+ c->ts.type = c->ts.u.derived->ts.type;
+ c->ts.kind = c->ts.u.derived->ts.kind;
+ c->ts.f90_type = c->ts.u.derived->ts.f90_type;
if (c->initializer)
{
c->initializer->ts.type = c->ts.type;
if (c->attr.proc_pointer)
field_type = gfc_get_ppc_type (c);
else if (c->ts.type == BT_DERIVED)
- field_type = c->ts.derived->backend_decl;
+ field_type = c->ts.u.derived->backend_decl;
else
{
if (c->ts.type == BT_CHARACTER)
{
/* Evaluate the string length. */
- gfc_conv_const_charlen (c->ts.cl);
- gcc_assert (c->ts.cl->backend_decl);
+ gfc_conv_const_charlen (c->ts.u.cl);
+ gcc_assert (c->ts.u.cl->backend_decl);
}
field_type = gfc_typenode_for_spec (&c->ts);
arg = sym;
if (arg->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (arg->ts.cl);
+ gfc_conv_const_charlen (arg->ts.u.cl);
/* Some functions we use an extra parameter for the return value. */
if (gfc_return_by_reference (sym))
/* Evaluate constant character lengths here so that they can be
included in the type. */
if (arg->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (arg->ts.cl);
+ gfc_conv_const_charlen (arg->ts.u.cl);
if (arg->attr.flavor == FL_PROCEDURE)
{
OSDN Git Service
