OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/40941 (gfc_typespec: put derived and cl into union) 

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.

From-SVN: r150725
This commit is contained in:
Janus Weil 2009-08-13 21:46:46 +02:00
parent f100a4a841
commit bc21d3152f
29 changed files with 773 additions and 728 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/fortran/ChangeLog
View File

@ -1,3 +1,43 @@
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

32
gcc/fortran/array.c
View File

@ -968,8 +968,8 @@ done:
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;
@ -1588,25 +1588,25 @@ gfc_resolve_character_array_constructor (gfc_expr *expr)
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. */
@ -1630,11 +1630,11 @@ got_charlen:
- 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
@ -1658,18 +1658,18 @@ got_charlen:
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
@ -1683,16 +1683,16 @@ got_charlen:
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, &current_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))

22
gcc/fortran/check.c
View File

@ -410,20 +410,20 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
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;
@ -1400,12 +1400,12 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
/* 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;

10
gcc/fortran/data.c
View File

@ -154,7 +154,7 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
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)
{
@ -379,7 +379,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
/* 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);
@ -417,7 +417,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
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);
}
@ -569,7 +569,7 @@ gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *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);
@ -716,7 +716,7 @@ formalize_structure_cons (gfc_expr *expr)
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;

141
gcc/fortran/decl.c
View File

@ -622,8 +622,8 @@ char_len_param_value (gfc_expr **expr)
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;
}
}
@ -938,7 +938,7 @@ verify_c_interop_param (gfc_symbol *sym)
"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 "
@ -951,7 +951,7 @@ verify_c_interop_param (gfc_symbol *sym)
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)
{
@ -1045,7 +1045,7 @@ build_sym (const char *name, gfc_charlen *cl,
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)
@ -1253,42 +1253,42 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
&& 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)
@ -1297,8 +1297,8 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
{
/* 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);
@ -1389,7 +1389,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
/* 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");
@ -1410,7 +1410,8 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
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;
@ -1423,27 +1424,27 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **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)
{
@ -1609,14 +1610,14 @@ variable_decl (int elem)
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;
@ -1634,8 +1635,8 @@ variable_decl (int elem)
{
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;
@ -1707,13 +1708,13 @@ variable_decl (int elem)
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 "
@ -2241,7 +2242,7 @@ done:
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
@ -2387,10 +2388,10 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
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;
}
@ -2423,7 +2424,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
return MATCH_ERROR;
gfc_set_sym_referenced (sym);
ts->derived = sym;
ts->u.derived = sym;
return MATCH_YES;
@ -2614,11 +2615,11 @@ gfc_match_implicit (void)
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. */
@ -3330,8 +3331,8 @@ set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
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;
@ -3473,9 +3474,9 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
/* 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));
@ -3679,7 +3680,7 @@ gfc_match_data_decl (void)
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)
{
@ -3687,7 +3688,7 @@ gfc_match_data_decl (void)
goto cleanup;
}
current_ts.derived = sym;
current_ts.u.derived = sym;
}
m = match_attr_spec ();
@ -3697,21 +3698,21 @@ gfc_match_data_decl (void)
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
@ -6202,30 +6203,30 @@ do_parm (void)
}
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;
@ -6762,7 +6763,7 @@ gfc_match_derived_decl (void)
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. */

6
gcc/fortran/dump-parse-tree.c
View File

@ -85,11 +85,11 @@ show_typespec (gfc_typespec *ts)
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:
@ -354,7 +354,7 @@ show_expr (gfc_expr *p)
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;

40
gcc/fortran/expr.c
View File

@ -1504,14 +1504,14 @@ simplify_const_ref (gfc_expr *p)
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);
@ -1681,8 +1681,8 @@ gfc_simplify_expr (gfc_expr *p, int type)
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;
@ -2102,7 +2102,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
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);
@ -3337,7 +3337,7 @@ gfc_default_initializer (gfc_typespec *ts)
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;
@ -3348,10 +3348,10 @@ gfc_default_initializer (gfc_typespec *ts)
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 ();
@ -3421,10 +3421,10 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
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)
@ -3502,11 +3502,11 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
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;

12
gcc/fortran/gfortran.h
View File

@ -833,13 +833,19 @@ gfc_charlen;
#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;

54
gcc/fortran/interface.c
View File

@ -410,17 +410,17 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
/* 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;
@ -454,10 +454,10 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
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);
}
@ -1386,9 +1386,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
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)
@ -1551,9 +1551,9 @@ get_sym_storage_size (gfc_symbol *sym)
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;
}
@ -1599,11 +1599,11 @@ get_expr_storage_size (gfc_expr *e)
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;
@ -1869,28 +1869,28 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
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;
}

78
gcc/fortran/iresolve.c
View File

@ -62,16 +62,16 @@ gfc_get_string (const char *format, ...)
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);
}
@ -161,8 +161,8 @@ gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
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),
@ -651,8 +651,8 @@ gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
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);
}
@ -1058,8 +1058,8 @@ gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
{
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);
}
@ -1125,8 +1125,8 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
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);
}
@ -2175,8 +2175,8 @@ gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
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);
}
@ -2205,8 +2205,8 @@ gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
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);
}
@ -2235,8 +2235,8 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
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);
}
@ -2341,16 +2341,16 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
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);
}
}
@ -2498,8 +2498,8 @@ gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
{
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);
}
@ -3077,8 +3077,8 @@ gfc_resolve_ctime_sub (gfc_code *c)
{
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);
}
@ -3180,8 +3180,8 @@ gfc_resolve_fgetc_sub (gfc_code *c)
{
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);
}
@ -3225,8 +3225,8 @@ gfc_resolve_fputc_sub (gfc_code *c)
{
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);
}
@ -3274,8 +3274,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
{
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);
}
@ -3283,8 +3283,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
{
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);
}
@ -3292,8 +3292,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
{
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);
}
@ -3316,8 +3316,8 @@ gfc_resolve_ftell_sub (gfc_code *c)
{
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);
}
@ -3336,8 +3336,8 @@ gfc_resolve_ttynam_sub (gfc_code *c)
{
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);
}

4
gcc/fortran/match.c
View File

@ -2264,7 +2264,7 @@ gfc_match_allocate (void)
}
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
@ -3214,7 +3214,7 @@ gfc_match_namelist (void)
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);

6
gcc/fortran/misc.c
View File

@ -67,9 +67,9 @@ void
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 */
@ -184,7 +184,7 @@ gfc_typename (gfc_typespec *ts)
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");

6
gcc/fortran/module.c
View File

@ -2038,7 +2038,7 @@ mio_typespec (gfc_typespec *ts)
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);
@ -2054,12 +2054,12 @@ mio_typespec (gfc_typespec *ts)
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 ();
}

6
gcc/fortran/openmp.c
View File

@ -873,7 +873,7 @@ resolve_omp_clauses (gfc_code *code)
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);
}
@ -884,7 +884,7 @@ resolve_omp_clauses (gfc_code *code)
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);
}
@ -916,7 +916,7 @@ resolve_omp_clauses (gfc_code *code)
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)

16
gcc/fortran/parse.c
View File

@ -2049,24 +2049,24 @@ endType:
{
/* 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;
}
@ -2320,7 +2320,7 @@ match_deferred_characteristics (gfc_typespec * ts)
{
ts->kind = 0;
if (!ts->derived || !ts->derived->components)
if (!ts->u.derived || !ts->u.derived->components)
m = MATCH_ERROR;
}
@ -2360,8 +2360,8 @@ check_function_result_typed (void)
/* 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);
}
@ -2540,7 +2540,7 @@ declSt:
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;
}

24
gcc/fortran/primary.c
View File

@ -1770,7 +1770,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
sym = sym->ts.derived;
sym = sym->ts.u.derived;
for (;;)
{
@ -1864,7 +1864,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|| gfc_match_char ('%') != MATCH_YES)
break;
sym = component->ts.derived;
sym = component->ts.u.derived;
}
check_substring:
@ -1881,7 +1881,7 @@ 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)
@ -1893,7 +1893,7 @@ check_substring:
primary->expr_type = EXPR_SUBSTRING;
if (substring)
primary->ts.cl = NULL;
primary->ts.u.cl = NULL;
break;
@ -1990,7 +1990,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
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;
@ -2106,7 +2106,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
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;
@ -2284,13 +2284,13 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
&& 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;
@ -2335,7 +2335,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
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;
@ -2758,7 +2758,7 @@ gfc_match_rvalue (gfc_expr **result)
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;
@ -2780,7 +2780,7 @@ gfc_match_rvalue (gfc_expr **result)
e->ts = sym->ts;
if (e->ref)
e->ts.cl = NULL;
e->ts.u.cl = NULL;
m = MATCH_YES;
break;
}
@ -2957,7 +2957,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
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;
}

361
gcc/fortran/resolve.c
View File

@ -103,16 +103,16 @@ is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
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;
@ -294,7 +294,7 @@ resolve_formal_arglist (gfc_symbol *proc)
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 "
@ -372,7 +372,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
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);
@ -552,16 +552,16 @@ resolve_entries (gfc_namespace *ns)
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,
@ -688,7 +688,7 @@ has_default_initializer (gfc_symbol *der)
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;
@ -718,16 +718,16 @@ resolve_common_vars (gfc_symbol *sym, bool named_common)
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);
@ -826,15 +826,15 @@ resolve_structure_cons (gfc_expr *expr)
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;
}
@ -2191,9 +2191,9 @@ is_scalar_expr_ptr (gfc_expr *expr)
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;
}
@ -2224,9 +2224,9 @@ is_scalar_expr_ptr (gfc_expr *expr)
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)
@ -2376,12 +2376,12 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
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)
{
@ -2536,8 +2536,8 @@ resolve_function (gfc_expr *expr)
&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)
@ -2687,7 +2687,7 @@ resolve_function (gfc_expr *expr)
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
@ -3396,7 +3396,7 @@ resolve_operator (gfc_expr *e)
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:
@ -3924,7 +3924,7 @@ find_array_spec (gfc_expr *e)
case REF_COMPONENT:
if (derived == NULL)
derived = e->symtree->n.sym->ts.derived;
derived = e->symtree->n.sym->ts.u.derived;
c = derived->components;
@ -3933,7 +3933,7 @@ find_array_spec (gfc_expr *e)
{
/* Track the sequence of component references. */
if (c->ts.type == BT_DERIVED)
derived = c->ts.derived;
derived = c->ts.u.derived;
break;
}
@ -4116,10 +4116,10 @@ gfc_resolve_substring_charlen (gfc_expr *e)
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;
@ -4128,8 +4128,8 @@ gfc_resolve_substring_charlen (gfc_expr *e)
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);
@ -4139,7 +4139,7 @@ gfc_resolve_substring_charlen (gfc_expr *e)
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;
@ -4147,15 +4147,15 @@ gfc_resolve_substring_charlen (gfc_expr *e)
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);
}
@ -4447,7 +4447,7 @@ resolve_variable (gfc_expr *e)
/* 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)
@ -4592,26 +4592,26 @@ gfc_resolve_character_operator (gfc_expr *e)
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;
}
@ -4636,12 +4636,12 @@ fixup_charlen (gfc_expr *e)
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;
}
@ -4817,10 +4817,10 @@ check_typebound_baseobject (gfc_expr* e)
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;
}
@ -5111,7 +5111,7 @@ gfc_resolve_expr (gfc_expr *e)
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);
@ -5171,7 +5171,7 @@ gfc_resolve_expr (gfc_expr *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;
@ -5414,7 +5414,7 @@ derived_inaccessible (gfc_symbol *sym)
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;
}
@ -6344,21 +6344,21 @@ resolve_transfer (gfc_code *code)
{
/* 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);
@ -6925,7 +6925,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
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);
@ -6974,18 +6974,18 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
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 "
@ -7022,7 +7022,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
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 "
@ -7716,7 +7716,7 @@ apply_default_init (gfc_symbol *sym)
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)
@ -7861,10 +7861,10 @@ build_default_init_expr (gfc_symbol *sym)
/* 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++)
@ -7977,17 +7977,17 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
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;
}
@ -8005,7 +8005,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
&& 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",
@ -8016,10 +8016,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
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;
}
@ -8083,7 +8083,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
/* 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 "
@ -8189,7 +8189,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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)
@ -8229,9 +8229,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
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",
@ -8239,7 +8239,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
== 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;
}
}
@ -8252,9 +8252,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
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 "
@ -8263,7 +8263,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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;
}
}
@ -8277,9 +8277,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
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 "
@ -8288,7 +8288,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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;
}
}
@ -8330,7 +8330,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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))
@ -8499,7 +8499,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
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);
@ -9181,7 +9181,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
/* 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,
@ -9450,12 +9450,12 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
/* 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')
@ -9524,7 +9524,7 @@ resolve_fl_derived (gfc_symbol *sym)
/* 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,
@ -9585,14 +9585,14 @@ resolve_fl_derived (gfc_symbol *sym)
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;
}
}
@ -9600,10 +9600,10 @@ resolve_fl_derived (gfc_symbol *sym)
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,
@ -9612,18 +9612,18 @@ resolve_fl_derived (gfc_symbol *sym)
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,
@ -9644,11 +9644,11 @@ resolve_fl_derived (gfc_symbol *sym)
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)
@ -9716,7 +9716,7 @@ resolve_fl_namelist (gfc_symbol *sym)
/* 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",
@ -9726,8 +9726,8 @@ resolve_fl_namelist (gfc_symbol *sym)
/* 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))
{
@ -9762,7 +9762,7 @@ resolve_fl_namelist (gfc_symbol *sym)
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",
@ -9770,7 +9770,7 @@ resolve_fl_namelist (gfc_symbol *sym)
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",
@ -9954,12 +9954,12 @@ resolve_symbol (gfc_symbol *sym)
}
}
/* 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')
@ -10059,7 +10059,7 @@ resolve_symbol (gfc_symbol *sym)
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 "
@ -10111,14 +10111,14 @@ resolve_symbol (gfc_symbol *sym)
/* 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;
}
@ -10147,12 +10147,12 @@ resolve_symbol (gfc_symbol *sym)
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;
}
@ -10161,23 +10161,23 @@ resolve_symbol (gfc_symbol *sym)
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++;
}
}
@ -10187,15 +10187,15 @@ resolve_symbol (gfc_symbol *sym)
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
@ -10206,7 +10206,7 @@ resolve_symbol (gfc_symbol *sym)
&& 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)
{
@ -10810,11 +10810,11 @@ sequence_type (gfc_typespec ts)
{
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;
@ -10862,7 +10862,6 @@ sequence_type (gfc_typespec ts)
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)
@ -10886,7 +10885,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
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 "
@ -10896,9 +10895,8 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
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
@ -10932,7 +10930,6 @@ static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
@ -10996,11 +10993,11 @@ resolve_equivalence (gfc_equiv *eq)
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);
@ -11051,8 +11048,8 @@ resolve_equivalence (gfc_equiv *eq)
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:
@ -11185,15 +11182,15 @@ resolve_fntype (gfc_namespace *ns)
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)
@ -11227,9 +11224,9 @@ check_uop_procedure (gfc_symbol *sym, locus where)
}
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);

32
gcc/fortran/simplify.c
View File

@ -3217,12 +3217,12 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
}
}
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
@ -4102,7 +4102,7 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
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;
}
@ -4300,14 +4300,14 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
}
/* 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;
}
@ -4335,7 +4335,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
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
{
@ -4364,8 +4364,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
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);
@ -5267,7 +5267,7 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
return NULL;
if (source->ts.type == BT_CHARACTER)
result->ts.cl = source->ts.cl;
result->ts.u.cl = source->ts.u.cl;
return result;
}
@ -5623,7 +5623,7 @@ gfc_simplify_transpose (gfc_expr *matrix)
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;
@ -5706,7 +5706,7 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
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;
@ -6087,7 +6087,7 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
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;
}

62
gcc/fortran/symbol.c
View File

@ -269,10 +269,10 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
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)
@ -1774,10 +1774,10 @@ gfc_add_component (gfc_symbol *sym, const char *name,
}
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;
}
@ -1810,8 +1810,8 @@ switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
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);
@ -1863,8 +1863,8 @@ gfc_use_derived (gfc_symbol *sym)
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);
@ -1917,7 +1917,7 @@ gfc_find_component (gfc_symbol *sym, const char *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)
@ -3263,8 +3263,8 @@ gfc_is_var_automatic (gfc_symbol *sym)
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;
}
@ -3481,14 +3481,14 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
/* 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
{
@ -3587,10 +3587,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
/* 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
@ -3603,7 +3603,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
? "_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);
}
@ -3624,7 +3624,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
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). */
@ -3728,7 +3728,7 @@ gen_cptr_param (gfc_formal_arglist **head,
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. */
@ -3956,7 +3956,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
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
@ -4219,8 +4219,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
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. */
@ -4264,7 +4264,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
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);
@ -4349,13 +4349,13 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
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. */
@ -4365,7 +4365,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
(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);
@ -4517,9 +4517,9 @@ gfc_get_derived_super_type (gfc_symbol* derived)
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;
}

10
gcc/fortran/target-memory.c
View File

@ -229,7 +229,7 @@ encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
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);
@ -435,9 +435,9 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
{
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));
@ -484,7 +484,7 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu
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)
@ -633,7 +633,7 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
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);

114
gcc/fortran/trans-array.c
View File

@ -1533,7 +1533,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
}
}
*len = ts->cl->backend_decl;
*len = ts->u.cl->backend_decl;
}
@ -1549,12 +1549,12 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
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
{
@ -1575,7 +1575,7 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
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;
}
}
@ -1825,8 +1825,8 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
/* 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)
@ -1845,14 +1845,14 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
/* 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);
@ -1866,7 +1866,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
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)
@ -2096,11 +2096,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
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);
@ -4002,9 +4002,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
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);
}
@ -4290,9 +4290,9 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
/* 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);
@ -4315,8 +4315,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
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);
@ -4381,8 +4381,8 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
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);
@ -4474,8 +4474,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
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));
@ -4867,11 +4867,11 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
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;
}
@ -4880,11 +4880,11 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
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)
@ -4895,21 +4895,21 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
/* 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;
}
@ -4932,19 +4932,19 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
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;
}
}
@ -5085,7 +5085,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* 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;
@ -5147,13 +5147,13 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
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;
@ -5469,7 +5469,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
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;
}
@ -5486,7 +5486,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
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)
{
@ -5543,12 +5543,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
/* 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);
}
@ -5854,7 +5854,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
@ -5868,7 +5868,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
}
@ -5896,7 +5896,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
}
@ -5922,7 +5922,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
}
@ -5985,7 +5985,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
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))
@ -5999,9 +5999,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|| 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);
}
@ -6035,7 +6035,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
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)
{
@ -6068,7 +6068,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
{
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);
}

4
gcc/fortran/trans-common.c
View File

@ -132,7 +132,7 @@ get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
/* 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));
@ -830,7 +830,7 @@ calculate_offset (gfc_expr *e)
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;

4
gcc/fortran/trans-const.c
View File

@ -342,8 +342,8 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr)
/* 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)

146
gcc/fortran/trans-decl.c
View File

@ -796,7 +796,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
/* 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)))
{
@ -928,10 +928,10 @@ gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
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];
@ -947,11 +947,11 @@ gfc_create_string_length (gfc_symbol * sym)
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
@ -1050,10 +1050,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* 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)
{
@ -1118,7 +1118,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
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;
}
}
@ -1171,7 +1171,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
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
@ -1696,9 +1696,9 @@ create_function_arglist (gfc_symbol * sym)
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);
@ -1707,13 +1707,13 @@ create_function_arglist (gfc_symbol * sym)
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,
@ -1721,7 +1721,7 @@ create_function_arglist (gfc_symbol * sym)
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. */
@ -1791,38 +1791,38 @@ create_function_arglist (gfc_symbol * sym)
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. */
@ -1993,7 +1993,7 @@ build_entry_thunks (gfc_namespace * ns)
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);
}
}
@ -2090,15 +2090,15 @@ build_entry_thunks (gfc_namespace * ns)
{
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;
}
}
@ -2207,10 +2207,10 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
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);
@ -2816,12 +2816,12 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
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);
@ -3009,9 +3009,9 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree 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);
@ -3022,7 +3022,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
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);
}
@ -3073,14 +3073,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
/* 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
@ -3096,7 +3096,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
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)
@ -3170,7 +3170,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
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);
@ -3197,8 +3197,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
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);
}
}
@ -3206,8 +3206,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
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);
}
@ -3381,7 +3381,7 @@ gfc_create_module_variable (gfc_symbol * sym)
{
tree length;
length = sym->ts.cl->backend_decl;
length = sym->ts.u.cl->backend_decl;
if (!INTEGER_CST_P (length))
{
pushdecl (length);
@ -3511,7 +3511,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
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)
@ -3557,12 +3557,12 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
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)
@ -3690,10 +3690,10 @@ generate_dependency_declarations (gfc_symbol *sym)
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)
{
@ -3744,8 +3744,8 @@ generate_local_decl (gfc_symbol * sym)
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);
@ -3756,7 +3756,7 @@ generate_local_decl (gfc_symbol * 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)
||
@ -3887,7 +3887,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
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);
@ -4224,10 +4224,10 @@ gfc_generate_function_code (gfc_namespace * ns)
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. */
@ -4328,11 +4328,11 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
}

176
gcc/fortran/trans-expr.c
View File

@ -201,12 +201,12 @@ gfc_get_expr_charlen (gfc_expr *e)
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;
}
@ -214,7 +214,7 @@ gfc_get_expr_charlen (gfc_expr *e)
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)
@ -223,7 +223,7 @@ gfc_get_expr_charlen (gfc_expr *e)
{
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:
@ -243,7 +243,7 @@ gfc_get_expr_charlen (gfc_expr *e)
}
/* 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). */
@ -276,7 +276,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
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);
@ -472,7 +472,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
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;
@ -513,7 +513,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
/* 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);
}
@ -662,10 +662,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
/* 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);
}
@ -1159,7 +1159,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
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)
{
@ -1723,16 +1723,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
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;
}
}
@ -1764,7 +1764,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
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);
@ -1809,9 +1809,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
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);
@ -1820,7 +1820,7 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
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;
}
}
@ -1907,12 +1907,12 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
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:
@ -2025,11 +2025,11 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
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);
}
}
@ -2050,10 +2050,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
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. */
@ -2173,8 +2173,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
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)
@ -2186,7 +2186,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
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;
@ -2315,7 +2315,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
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);
@ -2343,7 +2343,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * 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. */
@ -2457,9 +2457,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
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;
@ -2572,8 +2572,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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));
@ -2753,11 +2753,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& 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;
}
}
@ -2771,7 +2771,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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))
{
@ -2798,11 +2798,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
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);
}
@ -2912,7 +2912,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -2927,7 +2927,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -2937,9 +2937,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* 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);
@ -2952,7 +2952,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Set up a charlen structure for it. */
cl.next = NULL;
cl.length = NULL;
ts.cl = &cl;
ts.u.cl = &cl;
len = cl.backend_decl;
}
@ -3025,7 +3025,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -3419,8 +3419,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
/* 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),
@ -3457,22 +3457,22 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
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. */
@ -3559,9 +3559,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
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);
@ -3591,7 +3591,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
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);
@ -3679,7 +3679,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
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);
@ -3766,8 +3766,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * 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,
@ -3872,7 +3872,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * 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);
@ -3892,7 +3892,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
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. */
@ -3928,13 +3928,13 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
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)
{
@ -4004,8 +4004,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
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)
@ -4018,9 +4018,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
/* 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;
}
}
@ -4389,7 +4389,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
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;
@ -4409,7 +4409,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
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);
@ -4426,7 +4426,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
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);
@ -4504,16 +4504,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
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;
}
@ -4887,13 +4887,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
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);
}
@ -4983,7 +4983,7 @@ copyable_array_p (gfc_expr * expr)
return false;
case BT_DERIVED:
return !expr->ts.derived->attr.alloc_comp;
return !expr->ts.u.derived->attr.alloc_comp;
default:
break;

6
gcc/fortran/trans-intrinsic.c
View File

@ -3479,7 +3479,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
&& (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;
}
@ -4629,7 +4629,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
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)
@ -4883,7 +4883,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
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:

19
gcc/fortran/trans-io.c
View File

@ -1591,7 +1591,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
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,
@ -1624,7 +1624,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
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,
@ -2005,8 +2005,9 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
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
@ -2014,14 +2015,14 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
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;
@ -2093,7 +2094,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
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);

20
gcc/fortran/trans-stmt.c
View File

@ -1830,7 +1830,7 @@ check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
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;
@ -2539,17 +2539,17 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
&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);
@ -4024,10 +4024,10 @@ gfc_trans_allocate (gfc_code * code)
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);
}
@ -4130,7 +4130,7 @@ gfc_trans_deallocate (gfc_code *code)
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;
@ -4143,7 +4143,7 @@ gfc_trans_deallocate (gfc_code *code)
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);
}

50
gcc/fortran/trans-types.c
View File

@ -1000,8 +1000,8 @@ gfc_typenode_for_spec (gfc_typespec * spec)
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;
@ -1023,21 +1023,21 @@ gfc_typenode_for_spec (gfc_typespec * spec)
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:
@ -1046,8 +1046,8 @@ gfc_typenode_for_spec (gfc_typespec * spec)
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;
@ -1765,7 +1765,7 @@ gfc_sym_type (gfc_symbol * sym)
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
@ -1879,10 +1879,10 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
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;
@ -1898,7 +1898,7 @@ gfc_get_ppc_type (gfc_component* c)
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);
}
@ -2038,17 +2038,17 @@ gfc_get_derived_type (gfc_symbol * derived)
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;
@ -2070,14 +2070,14 @@ gfc_get_derived_type (gfc_symbol * derived)
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);
@ -2261,7 +2261,7 @@ gfc_get_function_type (gfc_symbol * sym)
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))
@ -2286,7 +2286,7 @@ gfc_get_function_type (gfc_symbol * 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)
{