Skip to content

R
riscv-gcc-1
Commit 636dff67 by Steven G. Kargl
Options

decl.c, [...]: Update Copyright dates. 

2007-01-07  Steven G. Kargl  <kargl@gcc.gnu.org>

    * decl.c, dump-parse-tree.c, error.c, data.c, expr.c, dependency.c,
    convert.c:  Update Copyright dates.  Fix whitespace.

From-SVN: r120552
parent cd85e27a
Showing with 645 additions and 717 deletions
gcc/fortran/ChangeLog
2007-01-07 Steven G. Kargl <kargl@gcc.gnu.org>
* decl.c, dump-parse-tree.c, error.c, data.c, expr.c, dependency.c,
convert.c: Update Copyright dates. Fix whitespace.
2007-01-07 Bernhard Fischer <aldot@gcc.gnu.org>
* data.c (gfc_assign_data_value): Fix whitespace.
......
gcc/fortran/convert.c
/* Language-level data type conversion for GNU C.
Copyright (C) 1987, 1988, 1991, 1998, 2002 Free Software Foundation, Inc.
Copyright (C) 1987, 1988, 1991, 1998, 2002, 2007
Free Software Foundation, Inc.
This file is part of GCC.
......@@ -57,9 +58,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
In expr.c: expand_expr, for operands of a MULT_EXPR.
In fold-const.c: fold.
In tree.c: get_narrower and get_unwidened. */
/* Subroutines of `convert'. */
/* Create an expression whose value is that of EXPR,
......@@ -104,7 +104,7 @@ convert (tree type, tree expr)
e = gfc_truthvalue_conversion (e);
/* If we have a NOP_EXPR, we must fold it here to avoid
infinite recursion between fold () and convert (). */
infinite recursion between fold () and convert (). */
if (TREE_CODE (e) == NOP_EXPR)
return fold_build1 (NOP_EXPR, type, TREE_OPERAND (e, 0));
else
......
gcc/fortran/data.c
/* Supporting functions for resolving DATA statement.
Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
This file is part of GCC.
......@@ -22,14 +22,14 @@ Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
/* Notes for DATA statement implementation:
We first assign initial value to each symbol by gfc_assign_data_value
during resolveing DATA statement. Refer to check_data_variable and
traverse_data_list in resolve.c.
The complexity exists in the handling of array section, implied do
and array of struct appeared in DATA statement.
We call gfc_conv_structure, gfc_con_array_array_initializer,
etc., to convert the initial value. Refer to trans-expr.c and
trans-array.c. */
......@@ -42,7 +42,7 @@ static void formalize_init_expr (gfc_expr *);
/* Calculate the array element offset. */
static void
get_array_index (gfc_array_ref * ar, mpz_t * offset)
get_array_index (gfc_array_ref *ar, mpz_t *offset)
{
gfc_expr *e;
int i;
......@@ -61,14 +61,15 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset)
if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
|| (gfc_is_constant_expr (ar->as->upper[i]) == 0)
|| (gfc_is_constant_expr (e) == 0))
gfc_error ("non-constant array in DATA statement %L", &ar->where);
gfc_error ("non-constant array in DATA statement %L", &ar->where);
mpz_set (tmp, e->value.integer);
mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
......@@ -87,39 +88,40 @@ find_con_by_offset (splay_tree spt, mpz_t offset)
gfc_constructor *con;
splay_tree_node sptn;
/* The complexity is due to needing quick access to the linked list of
constructors. Both a linked list and a splay tree are used, and both are
kept up to date if they are array elements (which is the only time that
a specific constructor has to be found). */
/* The complexity is due to needing quick access to the linked list of
constructors. Both a linked list and a splay tree are used, and both
are kept up to date if they are array elements (which is the only time
that a specific constructor has to be found). */
gcc_assert (spt != NULL);
mpz_init (tmp);
sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si(offset));
sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
if (sptn)
ret = (gfc_constructor*) sptn->value;
else
{
/* Need to check and see if we match a range, so we will pull
the next lowest index and see if the range matches. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
the next lowest index and see if the range matches. */
sptn = splay_tree_predecessor (spt,
(splay_tree_key) mpz_get_si (offset));
if (sptn)
{
con = (gfc_constructor*) sptn->value;
if (mpz_cmp_ui (con->repeat, 1) > 0)
{
mpz_init (tmp);
mpz_add (tmp, con->n.offset, con->repeat);
if (mpz_cmp (offset, tmp) < 0)
ret = con;
mpz_clear (tmp);
}
else
ret = NULL; /* The range did not match. */
}
{
con = (gfc_constructor*) sptn->value;
if (mpz_cmp_ui (con->repeat, 1) > 0)
{
mpz_init (tmp);
mpz_add (tmp, con->n.offset, con->repeat);
if (mpz_cmp (offset, tmp) < 0)
ret = con;
mpz_clear (tmp);
}
else
ret = NULL; /* The range did not match. */
}
else
ret = NULL; /* No pred, so no match. */
ret = NULL; /* No pred, so no match. */
}
return ret;
......@@ -134,7 +136,7 @@ find_con_by_component (gfc_component *com, gfc_constructor *con)
for (; con; con = con->next)
{
if (com == con->n.component)
return con;
return con;
}
return NULL;
}
......@@ -146,8 +148,8 @@ find_con_by_component (gfc_component *com, gfc_constructor *con)
according to normal assignment rules. */
static gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gfc_ref * ref, gfc_expr * rvalue)
create_character_intializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
int len;
int start;
......@@ -181,14 +183,14 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
{
gfc_error ("failure to simplify substring reference in DATA"
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
return NULL;
}
......@@ -225,12 +227,13 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts,
return init;
}
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
LVALUE already has an initialization, we extend this, otherwise we
create a new one. */
void
gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
......@@ -262,7 +265,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
......@@ -289,38 +292,40 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
else
mpz_set (offset, index);
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints,NULL,NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
splay_tree_key j;
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
sptn = splay_tree_insert (spt, (splay_tree_key) mpz_get_si(offset),
(splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
j = (splay_tree_key) mpz_get_si (offset);
sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, j);
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
break;
......@@ -374,16 +379,16 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether they
are from data statements or F95 style declarations. Therefore,
check which is the most recent. */
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
#ifdef USE_MAPPED_LOCATION
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
? init : rvalue;
#else
expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
init : rvalue;
expr = (init->where.lb->linenum > rvalue->where.lb->linenum)
? init : rvalue;
#endif
gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
"of '%s' at %L", symbol->name, &expr->where);
......@@ -400,12 +405,13 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
last_con->expr = expr;
}
/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
value in RVALUE. For the nonce, LVALUE must refer to a full array, not
an array section. */
void
gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
mpz_t index, mpz_t repeat)
{
gfc_ref *ref;
......@@ -471,42 +477,44 @@ gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
/* Find the same element in the existing constructor. */
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints,NULL,NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
sptn = splay_tree_insert (spt, (splay_tree_key) mpz_get_si(offset),
(splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
else
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
splay_tree_key j;
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
j = (splay_tree_key) mpz_get_si (offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, j);
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
else
gcc_assert (ref->next != NULL);
break;
......@@ -612,10 +620,9 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
if ((cmp > 0 && forwards)
|| (cmp < 0 && ! forwards))
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
{
/* Reset index to start, then loop to advance the next index. */
/* Reset index to start, then loop to advance the next index. */
if (ar->start[i])
mpz_set (section_index[i], ar->start[i]->value.integer);
else
......@@ -635,7 +642,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
mpz_add (*offset_ret, tmp, *offset_ret);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
......@@ -648,7 +655,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
order. Also insert NULL entries if necessary. */
static void
formalize_structure_cons (gfc_expr * expr)
formalize_structure_cons (gfc_expr *expr)
{
gfc_constructor *head;
gfc_constructor *tail;
......@@ -710,7 +717,7 @@ formalize_structure_cons (gfc_expr * expr)
elements of the constructors are in the correct order. */
static void
formalize_init_expr (gfc_expr * expr)
formalize_init_expr (gfc_expr *expr)
{
expr_t type;
gfc_constructor *c;
......@@ -789,7 +796,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
}
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
......
gcc/fortran/decl.c
/* Declaration statement matcher
Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
......@@ -19,14 +20,12 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
......@@ -91,7 +90,7 @@ gfc_set_in_match_data (bool set_value)
/* Free a gfc_data_variable structure and everything beneath it. */
static void
free_variable (gfc_data_variable * p)
free_variable (gfc_data_variable *p)
{
gfc_data_variable *q;
......@@ -101,7 +100,6 @@ free_variable (gfc_data_variable * p)
gfc_free_expr (p->expr);
gfc_free_iterator (&p->iter, 0);
free_variable (p->list);
gfc_free (p);
}
}
......@@ -110,7 +108,7 @@ free_variable (gfc_data_variable * p)
/* Free a gfc_data_value structure and everything beneath it. */
static void
free_value (gfc_data_value * p)
free_value (gfc_data_value *p)
{
gfc_data_value *q;
......@@ -126,23 +124,22 @@ free_value (gfc_data_value * p)
/* Free a list of gfc_data structures. */
void
gfc_free_data (gfc_data * p)
gfc_free_data (gfc_data *p)
{
gfc_data *q;
for (; p; p = q)
{
q = p->next;
free_variable (p->var);
free_value (p->value);
gfc_free (p);
}
}
/* Free all data in a namespace. */
static void
gfc_free_data_all (gfc_namespace * ns)
{
......@@ -163,7 +160,7 @@ static match var_element (gfc_data_variable *);
parenthesis. */
static match
var_list (gfc_data_variable * parent)
var_list (gfc_data_variable *parent)
{
gfc_data_variable *tail, var;
match m;
......@@ -216,7 +213,7 @@ syntax:
variable-iterator list. */
static match
var_element (gfc_data_variable * new)
var_element (gfc_data_variable *new)
{
match m;
gfc_symbol *sym;
......@@ -232,7 +229,8 @@ var_element (gfc_data_variable * new)
sym = new->expr->symtree->n.sym;
if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns)
{
gfc_error ("Host associated variable '%s' may not be in the DATA "
"statement at %C", sym->name);
......@@ -240,10 +238,10 @@ var_element (gfc_data_variable * new)
}
if (gfc_current_state () != COMP_BLOCK_DATA
&& sym->attr.in_common
&& gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
"common block variable '%s' in DATA statement at %C",
sym->name) == FAILURE)
&& sym->attr.in_common
&& gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
"common block variable '%s' in DATA statement at %C",
sym->name) == FAILURE)
return MATCH_ERROR;
if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
......@@ -256,7 +254,7 @@ var_element (gfc_data_variable * new)
/* Match the top-level list of data variables. */
static match
top_var_list (gfc_data * d)
top_var_list (gfc_data *d)
{
gfc_data_variable var, *tail, *new;
match m;
......@@ -297,7 +295,7 @@ syntax:
static match
match_data_constant (gfc_expr ** result)
match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
......@@ -344,7 +342,7 @@ match_data_constant (gfc_expr ** result)
already been seen at this point. */
static match
top_val_list (gfc_data * data)
top_val_list (gfc_data *data)
{
gfc_data_value *new, *tail;
gfc_expr *expr;
......@@ -458,6 +456,7 @@ match_old_style_init (const char *name)
return m;
}
/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
we are matching a DATA statement and are therefore issuing an error
if we encounter something unexpected, if not, we're trying to match
......@@ -535,9 +534,8 @@ match_intent_spec (void)
specification expression or a '*'. */
static match
char_len_param_value (gfc_expr ** expr)
char_len_param_value (gfc_expr **expr)
{
if (gfc_match_char ('*') == MATCH_YES)
{
*expr = NULL;
......@@ -552,7 +550,7 @@ char_len_param_value (gfc_expr ** expr)
char_len_param_value in parenthesis. */
static match
match_char_length (gfc_expr ** expr)
match_char_length (gfc_expr **expr)
{
int length;
match m;
......@@ -602,13 +600,13 @@ syntax:
(located in another namespace). */
static int
find_special (const char *name, gfc_symbol ** result)
find_special (const char *name, gfc_symbol **result)
{
gfc_state_data *s;
int i;
i = gfc_get_symbol (name, NULL, result);
if (i==0)
if (i == 0)
goto end;
if (gfc_current_state () != COMP_SUBROUTINE
......@@ -622,7 +620,7 @@ find_special (const char *name, gfc_symbol ** result)
if (s->state != COMP_INTERFACE)
goto end;
if (s->sym == NULL)
goto end; /* Nameless interface */
goto end; /* Nameless interface */
if (strcmp (name, s->sym->name) == 0)
{
......@@ -642,8 +640,7 @@ end:
parent, then the symbol is just created in the current unit. */
static int
get_proc_name (const char *name, gfc_symbol ** result,
bool module_fcn_entry)
get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
{
gfc_symtree *st;
gfc_symbol *sym;
......@@ -671,9 +668,9 @@ get_proc_name (const char *name, gfc_symbol ** result,
this is handled using gsymbols to register unique,globally
accessible names. */
if (sym->attr.flavor != 0
&& sym->attr.proc != 0
&& (sym->attr.subroutine || sym->attr.function)
&& sym->attr.if_source != IFSRC_UNKNOWN)
&& sym->attr.proc != 0
&& (sym->attr.subroutine || sym->attr.function)
&& sym->attr.if_source != IFSRC_UNKNOWN)
gfc_error_now ("Procedure '%s' at %C is already defined at %L",
name, &sym->declared_at);
......@@ -681,13 +678,13 @@ get_proc_name (const char *name, gfc_symbol ** result,
signature for this is that ts.kind is set. Legitimate
references only set ts.type. */
if (sym->ts.kind != 0
&& !sym->attr.implicit_type
&& sym->attr.proc == 0
&& gfc_current_ns->parent != NULL
&& sym->attr.access == 0
&& !module_fcn_entry)
gfc_error_now ("Procedure '%s' at %C has an explicit interface"
" and must not have attributes declared at %L",
&& !sym->attr.implicit_type
&& sym->attr.proc == 0
&& gfc_current_ns->parent != NULL
&& sym->attr.access == 0
&& !module_fcn_entry)
gfc_error_now ("Procedure '%s' at %C has an explicit interface "
"and must not have attributes declared at %L",
name, &sym->declared_at);
}
......@@ -707,10 +704,10 @@ get_proc_name (const char *name, gfc_symbol ** result,
/* See if the procedure should be a module procedure */
if (((sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE) || module_fcn_entry)
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE) || module_fcn_entry)
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
rc = 2;
return rc;
......@@ -721,21 +718,20 @@ get_proc_name (const char *name, gfc_symbol ** result,
table. */
static try
build_sym (const char *name, gfc_charlen * cl,
gfc_array_spec ** as, locus * var_locus)
build_sym (const char *name, gfc_charlen *cl,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
gfc_symbol *sym;
/* if (find_special (name, &sym)) */
if (gfc_get_symbol (name, NULL, &sym))
return FAILURE;
/* Start updating the symbol table. Add basic type attribute
if present. */
if (current_ts.type != BT_UNKNOWN
&&(sym->attr.implicit_type == 0
|| !gfc_compare_types (&sym->ts, &current_ts))
&& (sym->attr.implicit_type == 0
|| !gfc_compare_types (&sym->ts, &current_ts))
&& gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
return FAILURE;
......@@ -758,13 +754,14 @@ build_sym (const char *name, gfc_charlen * cl,
return SUCCESS;
}
/* Set character constant to the given length. The constant will be padded or
truncated. */
void
gfc_set_constant_character_len (int len, gfc_expr * expr, bool array)
gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
{
char * s;
char *s;
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
......@@ -787,7 +784,7 @@ gfc_set_constant_character_len (int len, gfc_expr * expr, bool array)
if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
gfc_error_now ("The CHARACTER elements of the array constructor "
"at %L must have the same length (%d/%d)",
&expr->where, slen, len);
&expr->where, slen, len);
s[len] = '\0';
gfc_free (expr->value.character.string);
......@@ -806,7 +803,7 @@ gfc_set_constant_character_len (int len, gfc_expr * expr, bool array)
INIT points to its enumerator value. */
static void
create_enum_history(gfc_symbol *sym, gfc_expr *init)
create_enum_history (gfc_symbol *sym, gfc_expr *init)
{
enumerator_history *new_enum_history;
gcc_assert (sym != NULL && init != NULL);
......@@ -829,7 +826,7 @@ create_enum_history(gfc_symbol *sym, gfc_expr *init)
if (mpz_cmp (max_enum->initializer->value.integer,
new_enum_history->initializer->value.integer) < 0)
max_enum = new_enum_history;
max_enum = new_enum_history;
}
}
......@@ -837,7 +834,7 @@ create_enum_history(gfc_symbol *sym, gfc_expr *init)
/* Function to free enum kind history. */
void
gfc_free_enum_history(void)
gfc_free_enum_history (void)
{
enumerator_history *current = enum_history;
enumerator_history *next;
......@@ -857,8 +854,8 @@ gfc_free_enum_history(void)
expression to a symbol. */
static try
add_init_expr_to_sym (const char *name, gfc_expr ** initp,
locus * var_locus)
add_init_expr_to_sym (const char *name, gfc_expr **initp,
locus *var_locus)
{
symbol_attribute attr;
gfc_symbol *sym;
......@@ -905,9 +902,8 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
initializer. */
if (sym->attr.data)
{
gfc_error
("Variable '%s' at %C with an initializer already appears "
"in a DATA statement", sym->name);
gfc_error ("Variable '%s' at %C with an initializer already "
"appears in a DATA statement", sym->name);
return FAILURE;
}
......@@ -924,13 +920,13 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
{
/* If there are multiple CHARACTER variables declared on
the same line, we don't want them to share the same
length. */
length. */
sym->ts.cl = gfc_get_charlen ();
sym->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_ARRAY)
&& init->expr_type == EXPR_ARRAY)
sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
}
/* Update initializer character length according symbol. */
......@@ -971,8 +967,8 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
being built. */
static try
build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
gfc_array_spec ** as)
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
gfc_component *c;
......@@ -986,8 +982,7 @@ build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
return FAILURE;
}
if (gfc_current_block ()->attr.pointer
&& (*as)->rank != 0)
if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
{
if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
{
......@@ -1046,9 +1041,8 @@ build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
{
if (c->as->type != AS_EXPLICIT)
{
gfc_error
("Array component of structure at %C must have an explicit "
"shape");
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
return FAILURE;
}
}
......@@ -1060,7 +1054,7 @@ build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
/* Match a 'NULL()', and possibly take care of some side effects. */
match
gfc_match_null (gfc_expr ** result)
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
gfc_expr *e;
......@@ -1166,7 +1160,7 @@ variable_decl (int elem)
element. */
case MATCH_NO:
if (elem > 1 && current_ts.cl->length
&& current_ts.cl->length->expr_type != EXPR_CONSTANT)
&& current_ts.cl->length->expr_type != EXPR_CONSTANT)
{
cl = gfc_get_charlen ();
cl->next = gfc_current_ns->cl_list;
......@@ -1249,10 +1243,10 @@ variable_decl (int elem)
that the interface may specify a procedure that is not pure if the procedure
is defined to be pure(12.3.2). */
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
&& !gfc_current_ns->has_import_set)
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& current_ts.derived->ns != gfc_current_ns
&& !gfc_current_ns->has_import_set)
{
gfc_error ("the type of '%s' at %C has not been declared within the "
"interface", name);
......@@ -1298,7 +1292,6 @@ variable_decl (int elem)
{
if (gfc_match (" =>") == MATCH_YES)
{
if (!current_attr.pointer)
{
gfc_error ("Initialization at %C isn't for a pointer variable");
......@@ -1315,9 +1308,8 @@ variable_decl (int elem)
if (gfc_pure (NULL))
{
gfc_error
("Initialization of pointer at %C is not allowed in a "
"PURE procedure");
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
......@@ -1329,8 +1321,8 @@ variable_decl (int elem)
{
if (current_attr.pointer)
{
gfc_error
("Pointer initialization at %C requires '=>', not '='");
gfc_error ("Pointer initialization at %C requires '=>', "
"not '='");
m = MATCH_ERROR;
goto cleanup;
}
......@@ -1344,9 +1336,8 @@ variable_decl (int elem)
if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
{
gfc_error
("Initialization of variable at %C is not allowed in a "
"PURE procedure");
gfc_error ("Initialization of variable at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
......@@ -1358,7 +1349,8 @@ variable_decl (int elem)
if (initializer != NULL && current_attr.allocatable
&& gfc_current_state () == COMP_DERIVED)
{
gfc_error ("Initialization of allocatable component at %C is not allowed");
gfc_error ("Initialization of allocatable component at %C is not "
"allowed");
m = MATCH_ERROR;
goto cleanup;
}
......@@ -1371,16 +1363,16 @@ variable_decl (int elem)
if (gfc_current_state () == COMP_ENUM)
{
if (initializer == NULL)
initializer = gfc_enum_initializer (last_initializer, old_locus);
initializer = gfc_enum_initializer (last_initializer, old_locus);
if (initializer == NULL || initializer->ts.type != BT_INTEGER)
{
gfc_error("ENUMERATOR %L not initialized with integer expression",
{
gfc_error("ENUMERATOR %L not initialized with integer expression",
&var_locus);
m = MATCH_ERROR;
gfc_free_enum_history ();
goto cleanup;
}
m = MATCH_ERROR;
gfc_free_enum_history ();
goto cleanup;
}
/* Store this current initializer, for the next enumerator
variable to be parsed. */
......@@ -1395,8 +1387,7 @@ variable_decl (int elem)
else
{
if (current_ts.type == BT_DERIVED
&& !current_attr.pointer
&& !initializer)
&& !current_attr.pointer && !initializer)
initializer = gfc_default_initializer (&current_ts);
t = build_struct (name, cl, &initializer, &as);
}
......@@ -1415,7 +1406,7 @@ cleanup:
/* Match an extended-f77 kind specification. */
match
gfc_match_old_kind_spec (gfc_typespec * ts)
gfc_match_old_kind_spec (gfc_typespec *ts)
{
match m;
int original_kind;
......@@ -1433,18 +1424,18 @@ gfc_match_old_kind_spec (gfc_typespec * ts)
if (ts->type == BT_COMPLEX)
{
if (ts->kind % 2)
{
gfc_error ("Old-style type declaration %s*%d not supported at %C",
gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
{
gfc_error ("Old-style type declaration %s*%d not supported at %C",
gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
ts->kind /= 2;
}
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
gfc_error ("Old-style type declaration %s*%d not supported at %C",
gfc_basic_typename (ts->type), original_kind);
gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
......@@ -1461,7 +1452,7 @@ gfc_match_old_kind_spec (gfc_typespec * ts)
string is found, then we know we have an error. */
match
gfc_match_kind_spec (gfc_typespec * ts)
gfc_match_kind_spec (gfc_typespec *ts)
{
locus where;
gfc_expr *e;
......@@ -1532,7 +1523,7 @@ no_match:
declaration. We don't return MATCH_NO. */
static match
match_char_spec (gfc_typespec * ts)
match_char_spec (gfc_typespec *ts)
{
int i, kind, seen_length;
gfc_charlen *cl;
......@@ -1584,7 +1575,7 @@ match_char_spec (gfc_typespec * ts)
goto rparen;
}
/* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>" */
if (gfc_match (" len =") == MATCH_YES)
{
m = char_len_param_value (&len);
......@@ -1691,7 +1682,7 @@ done:
statement correctly. */
static match
match_type_spec (gfc_typespec * ts, int implicit_flag)
match_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
......@@ -1804,7 +1795,7 @@ get_kind:
{
c = gfc_peek_char();
if (!gfc_is_whitespace(c) && c != '*' && c != '('
&& c != ':' && c != ',')
&& c != ':' && c != ',')
return MATCH_NO;
}
......@@ -1827,7 +1818,6 @@ get_kind:
match
gfc_match_implicit_none (void)
{
return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
}
......@@ -1898,10 +1888,10 @@ match_implicit_range (void)
}
/* See if we can add the newly matched range to the pending
implicits from this IMPLICIT statement. We do not check for
conflicts with whatever earlier IMPLICIT statements may have
set. This is done when we've successfully finished matching
the current one. */
implicits from this IMPLICIT statement. We do not check for
conflicts with whatever earlier IMPLICIT statements may have
set. This is done when we've successfully finished matching
the current one. */
if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
goto bad;
}
......@@ -2053,8 +2043,7 @@ gfc_match_import (void)
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: IMPORT statement at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
== FAILURE)
return MATCH_ERROR;
......@@ -2068,10 +2057,10 @@ gfc_match_import (void)
if (gfc_match (" ::") == MATCH_YES)
{
if (gfc_match_eos () == MATCH_YES)
{
gfc_error ("Expecting list of named entities at %C");
return MATCH_ERROR;
}
{
gfc_error ("Expecting list of named entities at %C");
return MATCH_ERROR;
}
}
for(;;)
......@@ -2080,30 +2069,30 @@ gfc_match_import (void)
switch (m)
{
case MATCH_YES:
if (gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym == NULL)
{
gfc_error ("Cannot IMPORT '%s' from host scoping unit "
"at %C - does not exist.", name);
return MATCH_ERROR;
}
if (gfc_find_symtree (gfc_current_ns->sym_root,name))
{
gfc_warning ("'%s' is already IMPORTed from host scoping unit "
"at %C.", name);
goto next_item;
}
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
st->n.sym = sym;
sym->refs++;
sym->ns = gfc_current_ns;
if (gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym == NULL)
{
gfc_error ("Cannot IMPORT '%s' from host scoping unit "
"at %C - does not exist.", name);
return MATCH_ERROR;
}
if (gfc_find_symtree (gfc_current_ns->sym_root,name))
{
gfc_warning ("'%s' is already IMPORTed from host scoping unit "
"at %C.", name);
goto next_item;
}
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
st->n.sym = sym;
sym->refs++;
sym->ns = gfc_current_ns;
goto next_item;
......@@ -2141,7 +2130,6 @@ syntax:
static match
match_attr_spec (void)
{
/* Modifiers that can exist in a type statement. */
typedef enum
{ GFC_DECL_BEGIN = 0,
......@@ -2203,10 +2191,10 @@ match_attr_spec (void)
break;
if (gfc_current_state () == COMP_ENUM)
{
gfc_error ("Enumerator cannot have attributes %C");
return MATCH_ERROR;
}
{
gfc_error ("Enumerator cannot have attributes %C");
return MATCH_ERROR;
}
seen[d]++;
seen_at[d] = gfc_current_locus;
......@@ -2232,10 +2220,10 @@ match_attr_spec (void)
{
t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
if (t == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
{
m = MATCH_ERROR;
goto cleanup;
}
}
/* No double colon, so assume that we've been looking at something
......@@ -2326,16 +2314,15 @@ match_attr_spec (void)
{
if (d == DECL_ALLOCATABLE)
{
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: ALLOCATABLE "
"attribute at %C in a TYPE "
"definition") == FAILURE)
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
"attribute at %C in a TYPE definition")
== FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
else
}
else
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
&seen_at[d]);
......@@ -2345,7 +2332,7 @@ match_attr_spec (void)
}
if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
&& gfc_current_state () != COMP_MODULE)
&& gfc_current_state () != COMP_MODULE)
{
if (d == DECL_PRIVATE)
attr = "PRIVATE";
......@@ -2409,8 +2396,8 @@ match_attr_spec (void)
break;
}
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: PROTECTED attribute at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
"attribute at %C")
== FAILURE)
t = FAILURE;
else
......@@ -2436,8 +2423,8 @@ match_attr_spec (void)
break;
case DECL_VALUE:
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: VALUE attribute at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
"at %C")
== FAILURE)
t = FAILURE;
else
......@@ -2446,7 +2433,7 @@ match_attr_spec (void)
case DECL_VOLATILE:
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: VOLATILE attribute at %C")
"Fortran 2003: VOLATILE attribute at %C")
== FAILURE)
t = FAILURE;
else
......@@ -2515,18 +2502,18 @@ gfc_match_data_decl (void)
goto ok;
gfc_find_symbol (current_ts.derived->name,
current_ts.derived->ns->parent, 1, &sym);
current_ts.derived->ns->parent, 1, &sym);
/* Any symbol that we find had better be a type definition
which has its components defined. */
which has its components defined. */
if (sym != NULL && sym->attr.flavor == FL_DERIVED
&& current_ts.derived->components != NULL)
&& current_ts.derived->components != NULL)
goto ok;
/* Now we have an error, which we signal, and then fix up
because the knock-on is plain and simple confusing. */
gfc_error_now ("Derived type at %C has not been previously defined "
"and so cannot appear in a derived type definition");
"and so cannot appear in a derived type definition");
current_attr.pointer = 1;
goto ok;
}
......@@ -2574,7 +2561,7 @@ cleanup:
returned (the null string was matched). */
static match
match_prefix (gfc_typespec * ts)
match_prefix (gfc_typespec *ts)
{
int seen_type;
......@@ -2623,9 +2610,8 @@ loop:
/* Copy attributes matched by match_prefix() to attributes on a symbol. */
static try
copy_prefix (symbol_attribute * dest, locus * where)
copy_prefix (symbol_attribute *dest, locus *where)
{
if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
return FAILURE;
......@@ -2642,7 +2628,7 @@ copy_prefix (symbol_attribute * dest, locus * where)
/* Match a formal argument list. */
match
gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
......@@ -2688,8 +2674,8 @@ gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
tail->sym = sym;
/* We don't add the VARIABLE flavor because the name could be a
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
if (sym != NULL && !st_flag
&& (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
|| gfc_missing_attr (&sym->attr, NULL) == FAILURE))
......@@ -2699,8 +2685,8 @@ gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
}
/* The name of a program unit can be in a different namespace,
so check for it explicitly. After the statement is accepted,
the name is checked for especially in gfc_get_symbol(). */
so check for it explicitly. After the statement is accepted,
the name is checked for especially in gfc_get_symbol(). */
if (gfc_new_block != NULL && sym != NULL
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
......@@ -2733,9 +2719,8 @@ ok:
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
gfc_error
("Duplicate symbol '%s' in formal argument list at %C",
p->sym->name);
gfc_error ("Duplicate symbol '%s' in formal argument list "
"at %C", p->sym->name);
m = MATCH_ERROR;
goto cleanup;
......@@ -2762,7 +2747,7 @@ cleanup:
ENTRY statement. Also matches the end-of-statement. */
static match
match_result (gfc_symbol * function, gfc_symbol ** result)
match_result (gfc_symbol * function, gfc_symbol **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *r;
......@@ -2783,8 +2768,7 @@ match_result (gfc_symbol * function, gfc_symbol ** result)
if (strcmp (function->name, name) == 0)
{
gfc_error
("RESULT variable at %C must be different than function name");
gfc_error ("RESULT variable at %C must be different than function name");
return MATCH_ERROR;
}
......@@ -2841,7 +2825,7 @@ gfc_match_function_decl (void)
if (m == MATCH_NO)
{
gfc_error ("Expected formal argument list in function "
"definition at %C");
"definition at %C");
m = MATCH_ERROR;
goto cleanup;
}
......@@ -2874,9 +2858,8 @@ gfc_match_function_decl (void)
|| copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
goto cleanup;
if (current_ts.type != BT_UNKNOWN
&& sym->ts.type != BT_UNKNOWN
&& !sym->attr.implicit_type)
if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
&& !sym->attr.implicit_type)
{
gfc_error ("Function '%s' at %C already has a type of %s", name,
gfc_basic_typename (sym->ts.type));
......@@ -2901,19 +2884,21 @@ cleanup:
return m;
}
/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
name of the entry, rather than the gfc_current_block name, and to return false
upon finding an existing global entry. */
/* This is mostly a copy of parse.c(add_global_procedure) but modified to
pass the name of the entry, rather than the gfc_current_block name, and
to return false upon finding an existing global entry. */
static bool
add_global_entry (const char * name, int sub)
add_global_entry (const char *name, int sub)
{
gfc_gsymbol *s;
s = gfc_get_gsymbol(name);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
......@@ -2925,6 +2910,7 @@ add_global_entry (const char * name, int sub)
return false;
}
/* Match an ENTRY statement. */
match
......@@ -2956,42 +2942,40 @@ gfc_match_entry (void)
gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
break;
case COMP_BLOCK_DATA:
gfc_error
("ENTRY statement at %C cannot appear within a BLOCK DATA");
gfc_error ("ENTRY statement at %C cannot appear within "
"a BLOCK DATA");
break;
case COMP_INTERFACE:
gfc_error
("ENTRY statement at %C cannot appear within an INTERFACE");
gfc_error ("ENTRY statement at %C cannot appear within "
"an INTERFACE");
break;
case COMP_DERIVED:
gfc_error
("ENTRY statement at %C cannot appear "
"within a DERIVED TYPE block");
gfc_error ("ENTRY statement at %C cannot appear within "
"a DERIVED TYPE block");
break;
case COMP_IF:
gfc_error
("ENTRY statement at %C cannot appear within an IF-THEN block");
gfc_error ("ENTRY statement at %C cannot appear within "
"an IF-THEN block");
break;
case COMP_DO:
gfc_error
("ENTRY statement at %C cannot appear within a DO block");
gfc_error ("ENTRY statement at %C cannot appear within "
"a DO block");
break;
case COMP_SELECT:
gfc_error
("ENTRY statement at %C cannot appear within a SELECT block");
gfc_error ("ENTRY statement at %C cannot appear within "
"a SELECT block");
break;
case COMP_FORALL:
gfc_error
("ENTRY statement at %C cannot appear within a FORALL block");
gfc_error ("ENTRY statement at %C cannot appear within "
"a FORALL block");
break;
case COMP_WHERE:
gfc_error
("ENTRY statement at %C cannot appear within a WHERE block");
gfc_error ("ENTRY statement at %C cannot appear within "
"a WHERE block");
break;
case COMP_CONTAINS:
gfc_error
("ENTRY statement at %C cannot appear "
"within a contained subprogram");
gfc_error ("ENTRY statement at %C cannot appear within "
"a contained subprogram");
break;
default:
gfc_internal_error ("gfc_match_entry(): Bad state");
......@@ -3000,8 +2984,9 @@ gfc_match_entry (void)
}
module_procedure = gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor
== FL_MODULE;
if (gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
......@@ -3040,14 +3025,14 @@ gfc_match_entry (void)
else
{
/* An entry in a function.
We need to take special care because writing
ENTRY f()
as
ENTRY f
is allowed, whereas
ENTRY f() RESULT (r)
can't be written as
ENTRY f RESULT (r). */
We need to take special care because writing
ENTRY f()
as
ENTRY f
is allowed, whereas
ENTRY f() RESULT (r)
can't be written as
ENTRY f RESULT (r). */
if (!add_global_entry (name, 0))
return MATCH_ERROR;
......@@ -3085,8 +3070,8 @@ gfc_match_entry (void)
if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
|| gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
|| gfc_add_function (&entry->attr, result->name,
NULL) == FAILURE)
|| gfc_add_function (&entry->attr, result->name, NULL)
== FAILURE)
return MATCH_ERROR;
entry->result = result;
......@@ -3179,8 +3164,7 @@ contained_procedure (void)
for (s=gfc_state_stack; s; s=s->previous)
if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
&& s->previous != NULL
&& s->previous->state == COMP_CONTAINS)
&& s->previous != NULL && s->previous->state == COMP_CONTAINS)
return 1;
return 0;
......@@ -3220,12 +3204,13 @@ set_enum_kind(void)
}
}
/* Match any of the various end-block statements. Returns the type of
END to the caller. The END INTERFACE, END IF, END DO and END
SELECT statements cannot be replaced by a single END statement. */
match
gfc_match_end (gfc_statement * st)
gfc_match_end (gfc_statement *st)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_compile_state state;
......@@ -3240,14 +3225,14 @@ gfc_match_end (gfc_statement * st)
return MATCH_NO;
state = gfc_current_state ();
block_name =
gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
if (state == COMP_CONTAINS)
{
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL ? NULL
: gfc_state_stack->previous->sym->name;
block_name = gfc_state_stack->previous->sym == NULL
? NULL : gfc_state_stack->previous->sym->name;
}
switch (state)
......@@ -3448,9 +3433,8 @@ attr_decl1 (void)
if (current_attr.dimension && m == MATCH_NO)
{
gfc_error
("Missing array specification at %L in DIMENSION statement",
&var_locus);
gfc_error ("Missing array specification at %L in DIMENSION "
"statement", &var_locus);
m = MATCH_ERROR;
goto cleanup;
}
......@@ -3458,14 +3442,14 @@ attr_decl1 (void)
if ((current_attr.allocatable || current_attr.pointer)
&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
{
gfc_error ("Array specification must be deferred at %L",
&var_locus);
gfc_error ("Array specification must be deferred at %L", &var_locus);
m = MATCH_ERROR;
goto cleanup;
}
}
/* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
/* Update symbol table. DIMENSION attribute is set
in gfc_set_array_spec(). */
if (current_attr.dimension == 0
&& gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
{
......@@ -3608,8 +3592,7 @@ cray_pointer_decl (void)
else if (cptr->ts.kind < gfc_index_integer_kind)
gfc_warning ("Cray pointer at %C has %d bytes of precision;"
" memory addresses require %d bytes",
cptr->ts.kind,
gfc_index_integer_kind);
cptr->ts.kind, gfc_index_integer_kind);
if (gfc_match_char (',') != MATCH_YES)
{
......@@ -3706,7 +3689,6 @@ gfc_match_external (void)
}
match
gfc_match_intent (void)
{
......@@ -3753,8 +3735,8 @@ gfc_match_pointer (void)
{
if (!gfc_option.flag_cray_pointer)
{
gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
" flag");
gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
"flag");
return MATCH_ERROR;
}
return cray_pointer_decl ();
......@@ -3772,7 +3754,6 @@ gfc_match_pointer (void)
match
gfc_match_allocatable (void)
{
gfc_clear_attr (&current_attr);
current_attr.allocatable = 1;
......@@ -3783,7 +3764,6 @@ gfc_match_allocatable (void)
match
gfc_match_dimension (void)
{
gfc_clear_attr (&current_attr);
current_attr.dimension = 1;
......@@ -3794,7 +3774,6 @@ gfc_match_dimension (void)
match
gfc_match_target (void)
{
gfc_clear_attr (&current_attr);
current_attr.target = 1;
......@@ -3835,9 +3814,8 @@ access_attr_decl (gfc_statement st)
if (gfc_get_symbol (name, NULL, &sym))
goto done;
if (gfc_add_access (&sym->attr,
(st ==
ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
? ACCESS_PUBLIC : ACCESS_PRIVATE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
......@@ -3863,14 +3841,13 @@ access_attr_decl (gfc_statement st)
if (uop->access == ACCESS_UNKNOWN)
{
uop->access =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
uop->access = (st == ST_PUBLIC)
? ACCESS_PUBLIC : ACCESS_PRIVATE;
}
else
{
gfc_error
("Access specification of the .%s. operator at %C has "
"already been specified", sym->name);
gfc_error ("Access specification of the .%s. operator at %C "
"has already been specified", sym->name);
goto done;
}
......@@ -3907,8 +3884,7 @@ gfc_match_protected (void)
}
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: PROTECTED statement at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
== FAILURE)
return MATCH_ERROR;
......@@ -3926,8 +3902,8 @@ gfc_match_protected (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_protected (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
goto next_item;
......@@ -3953,13 +3929,12 @@ syntax:
}
/* The PRIVATE statement is a bit weird in that it can be a attribute
declaration, but also works as a standlone statement inside of a
type declaration or a module. */
match
gfc_match_private (gfc_statement * st)
gfc_match_private (gfc_statement *st)
{
if (gfc_match ("private") != MATCH_YES)
......@@ -3989,7 +3964,7 @@ gfc_match_private (gfc_statement * st)
match
gfc_match_public (gfc_statement * st)
gfc_match_public (gfc_statement *st)
{
if (gfc_match ("public") != MATCH_YES)
......@@ -4112,9 +4087,8 @@ gfc_match_save (void)
{
if (gfc_current_ns->seen_save)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Blanket SAVE statement at %C follows previous "
"SAVE statement")
if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
"follows previous SAVE statement")
== FAILURE)
return MATCH_ERROR;
}
......@@ -4125,8 +4099,8 @@ gfc_match_save (void)
if (gfc_current_ns->save_all)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"SAVE statement at %C follows blanket SAVE statement")
if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
"blanket SAVE statement")
== FAILURE)
return MATCH_ERROR;
}
......@@ -4139,8 +4113,8 @@ gfc_match_save (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_save (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
goto next_item;
......@@ -4183,8 +4157,7 @@ gfc_match_value (void)
gfc_symbol *sym;
match m;
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: VALUE statement at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
== FAILURE)
return MATCH_ERROR;
......@@ -4202,8 +4175,8 @@ gfc_match_value (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_value (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
goto next_item;
......@@ -4234,8 +4207,7 @@ gfc_match_volatile (void)
gfc_symbol *sym;
match m;
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: VOLATILE statement at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
== FAILURE)
return MATCH_ERROR;
......@@ -4253,8 +4225,8 @@ gfc_match_volatile (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_volatile (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
goto next_item;
......@@ -4296,8 +4268,8 @@ gfc_match_modproc (void)
|| gfc_state_stack->previous == NULL
|| current_interface.type == INTERFACE_NAMELESS)
{
gfc_error
("MODULE PROCEDURE at %C must be in a generic module interface");
gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
"interface");
return MATCH_ERROR;
}
......@@ -4358,8 +4330,7 @@ loop:
{
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error
("Derived type at %C can only be PRIVATE within a MODULE");
gfc_error ("Derived type at %C can only be PRIVATE within a MODULE");
return MATCH_ERROR;
}
......@@ -4399,9 +4370,8 @@ loop:
|| strcmp (name, "logical") == 0
|| strcmp (name, "complex") == 0)
{
gfc_error
("Type name '%s' at %C cannot be the same as an intrinsic type",
name);
gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
"type", name);
return MATCH_ERROR;
}
......@@ -4426,9 +4396,8 @@ loop:
if (sym->components != NULL)
{
gfc_error
("Derived type definition of '%s' at %C has already been defined",
sym->name);
gfc_error ("Derived type definition of '%s' at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
......@@ -4481,8 +4450,7 @@ gfc_match_enum (void)
if (m != MATCH_YES)
return m;
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: ENUM AND ENUMERATOR at %C")
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM AND ENUMERATOR at %C")
== FAILURE)
return MATCH_ERROR;
......
gcc/fortran/dependency.c
/* Dependency analysis
Copyright (C) 2000, 2001, 2002, 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of GCC.
......@@ -24,7 +25,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
have different dependency checking functions for different types
if dependencies. Ideally these would probably be merged. */
#include "config.h"
#include "gfortran.h"
#include "dependency.h"
......@@ -52,7 +52,7 @@ gfc_dependency;
def if the value could not be determined. */
int
gfc_expr_is_one (gfc_expr * expr, int def)
gfc_expr_is_one (gfc_expr *expr, int def)
{
gcc_assert (expr != NULL);
......@@ -70,7 +70,7 @@ gfc_expr_is_one (gfc_expr * expr, int def)
and -2 if the relationship could not be determined. */
int
gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
{
gfc_actual_arglist *args1;
gfc_actual_arglist *args2;
......@@ -78,15 +78,14 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
if (e1->expr_type == EXPR_OP
&& (e1->value.op.operator == INTRINSIC_UPLUS
|| e1->value.op.operator == INTRINSIC_PARENTHESES))
|| e1->value.op.operator == INTRINSIC_PARENTHESES))
return gfc_dep_compare_expr (e1->value.op.op1, e2);
if (e2->expr_type == EXPR_OP
&& (e2->value.op.operator == INTRINSIC_UPLUS
|| e2->value.op.operator == INTRINSIC_PARENTHESES))
|| e2->value.op.operator == INTRINSIC_PARENTHESES))
return gfc_dep_compare_expr (e1, e2->value.op.op1);
if (e1->expr_type == EXPR_OP
&& e1->value.op.operator == INTRINSIC_PLUS)
if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_PLUS)
{
/* Compare X+C vs. X. */
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
......@@ -95,8 +94,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
return mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P+Q vs. R+S. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_PLUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
{
int l, r;
......@@ -129,8 +127,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X vs. X+C. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_PLUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
......@@ -139,8 +136,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X-C vs. X. */
if (e1->expr_type == EXPR_OP
&& e1->value.op.operator == INTRINSIC_MINUS)
if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_MINUS)
{
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
&& e1->value.op.op2->ts.type == BT_INTEGER
......@@ -148,8 +144,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
return -mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P-Q vs. R-S. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_MINUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
{
int l, r;
......@@ -169,8 +164,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X vs. X-C. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_MINUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
......@@ -218,8 +212,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
case EXPR_FUNCTION:
/* We can only compare calls to the same intrinsic function. */
if (e1->value.function.isym == 0
|| e2->value.function.isym == 0
if (e1->value.function.isym == 0 || e2->value.function.isym == 0
|| e1->value.function.isym != e2->value.function.isym)
return -2;
......@@ -275,7 +268,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
if the results are indeterminate. N is the dimension to compare. */
int
gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
{
gfc_expr *e1;
gfc_expr *e2;
......@@ -375,7 +368,7 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
whose data can be reused, otherwise return NULL. */
gfc_expr *
gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
{
if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
return NULL;
......@@ -439,8 +432,8 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
temporary. */
static int
gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
gfc_expr * expr)
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
gfc_expr *expr)
{
gcc_assert (var->expr_type == EXPR_VARIABLE);
gcc_assert (var->rank > 0);
......@@ -472,8 +465,8 @@ gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
array expression OTHER, not just variables. */
static int
gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
gfc_expr * expr)
gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
gfc_expr *expr)
{
switch (other->expr_type)
{
......@@ -498,8 +491,8 @@ gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
FNSYM is the function being called, or NULL if not known. */
int
gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
gfc_symbol * fnsym, gfc_actual_arglist * actual)
gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
gfc_symbol *fnsym, gfc_actual_arglist *actual)
{
gfc_formal_arglist *formal;
gfc_expr *expr;
......@@ -518,8 +511,7 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
continue;
/* Skip intent(in) arguments if OTHER itself is intent(in). */
if (formal
&& intent == INTENT_IN
if (formal && intent == INTENT_IN
&& formal->sym->attr.intent == INTENT_IN)
continue;
......@@ -550,12 +542,10 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
gfc_equiv_info *s, *fl1, *fl2;
gcc_assert (e1->expr_type == EXPR_VARIABLE
&& e2->expr_type == EXPR_VARIABLE);
&& e2->expr_type == EXPR_VARIABLE);
if (!e1->symtree->n.sym->attr.in_equivalence
|| !e2->symtree->n.sym->attr.in_equivalence
|| !e1->rank
|| !e2->rank)
|| !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
return 0;
/* Go through the equiv_lists and return 1 if the variables
......@@ -607,7 +597,7 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
temporary. */
int
gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
{
gfc_ref *ref;
int n;
......@@ -637,13 +627,10 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
return 1;
/* Symbols can only alias if they have the same type. */
if (ts1->type != BT_UNKNOWN
&& ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED
&& ts2->type != BT_DERIVED)
if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
{
if (ts1->type != ts2->type
|| ts1->kind != ts2->kind)
if (ts1->type != ts2->type || ts1->kind != ts2->kind)
return 0;
}
......@@ -710,7 +697,7 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
/* Determines overlapping for two array sections. */
static gfc_dependency
gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref l_ar;
gfc_expr *l_start;
......@@ -761,7 +748,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (!l_stride)
l_dir = 1;
else if (l_stride->expr_type == EXPR_CONSTANT
&& l_stride->ts.type == BT_INTEGER)
&& l_stride->ts.type == BT_INTEGER)
l_dir = mpz_sgn (l_stride->value.integer);
else if (l_start && l_end)
l_dir = gfc_dep_compare_expr (l_end, l_start);
......@@ -772,7 +759,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (!r_stride)
r_dir = 1;
else if (r_stride->expr_type == EXPR_CONSTANT
&& r_stride->ts.type == BT_INTEGER)
&& r_stride->ts.type == BT_INTEGER)
r_dir = mpz_sgn (r_stride->value.integer);
else if (r_start && r_end)
r_dir = gfc_dep_compare_expr (r_end, r_start);
......@@ -827,18 +814,18 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
if (l_dir == -1 && r_dir == 1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
}
/* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
if (l_dir == -1 && r_dir == 1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
}
/* Check for forward dependencies x:y vs. x+1:z. */
......@@ -874,7 +861,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
/* Determines overlapping for a single element and a section. */
static gfc_dependency
gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref *ref;
gfc_expr *elem;
......@@ -999,7 +986,7 @@ gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
return true, and assume a dependency. */
static bool
contains_forall_index_p (gfc_expr * expr)
contains_forall_index_p (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
......@@ -1074,7 +1061,7 @@ contains_forall_index_p (gfc_expr * expr)
/* Determines overlapping for two single element array references. */
static gfc_dependency
gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref l_ar;
gfc_array_ref r_ar;
......@@ -1099,8 +1086,7 @@ gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
/* However, we need to be careful when either scalar expression
contains a FORALL index, as these can potentially change value
during the scalarization/traversal of this array reference. */
if (contains_forall_index_p (r_start)
|| contains_forall_index_p (l_start))
if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
return GFC_DEP_OVERLAP;
if (i != -2)
......@@ -1141,8 +1127,7 @@ gfc_full_array_ref_p (gfc_ref *ref)
ref->u.ar.as->upper[i])))
return false;
/* Check the stride. */
if (ref->u.ar.stride[i]
&& !gfc_expr_is_one (ref->u.ar.stride[i], 0))
if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
return false;
}
return true;
......@@ -1155,13 +1140,12 @@ gfc_full_array_ref_p (gfc_ref *ref)
0 : array references are identical or not overlapping. */
int
gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
{
int n;
gfc_dependency fin_dep;
gfc_dependency this_dep;
fin_dep = GFC_DEP_ERROR;
/* Dependencies due to pointers should already have been identified.
We only need to check for overlapping array references. */
......@@ -1186,7 +1170,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
return 0;
case REF_ARRAY:
if (lref->u.ar.dimen != rref->u.ar.dimen)
if (lref->u.ar.dimen != rref->u.ar.dimen)
{
if (lref->u.ar.type == AR_FULL)
fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL
......@@ -1195,7 +1179,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
: GFC_DEP_OVERLAP;
else
return 1;
return 1;
break;
}
......
gcc/fortran/dump-parse-tree.c
/* Parse tree dumper
Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Steven Bosscher
This file is part of GCC.
......@@ -40,7 +41,7 @@ static int show_level = 0;
/* Do indentation for a specific level. */
static inline void
code_indent (int level, gfc_st_label * label)
code_indent (int level, gfc_st_label *label)
{
int i;
......@@ -68,9 +69,8 @@ show_indent (void)
/* Show type-specific information. */
void
gfc_show_typespec (gfc_typespec * ts)
gfc_show_typespec (gfc_typespec *ts)
{
gfc_status ("(%s ", gfc_basic_typename (ts->type));
switch (ts->type)
......@@ -95,9 +95,8 @@ gfc_show_typespec (gfc_typespec * ts)
/* Show an actual argument list. */
void
gfc_show_actual_arglist (gfc_actual_arglist * a)
gfc_show_actual_arglist (gfc_actual_arglist *a)
{
gfc_status ("(");
for (; a; a = a->next)
......@@ -122,7 +121,7 @@ gfc_show_actual_arglist (gfc_actual_arglist * a)
/* Show a gfc_array_spec array specification structure. */
void
gfc_show_array_spec (gfc_array_spec * as)
gfc_show_array_spec (gfc_array_spec *as)
{
const char *c;
int i;
......@@ -144,8 +143,8 @@ gfc_show_array_spec (gfc_array_spec * as)
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
default:
gfc_internal_error
("gfc_show_array_spec(): Unhandled array shape type.");
gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
"type.");
}
gfc_status (" %s ", c);
......@@ -233,9 +232,8 @@ gfc_show_array_ref (gfc_array_ref * ar)
/* Show a list of gfc_ref structures. */
void
gfc_show_ref (gfc_ref * p)
gfc_show_ref (gfc_ref *p)
{
for (; p; p = p->next)
switch (p->type)
{
......@@ -264,9 +262,8 @@ gfc_show_ref (gfc_ref * p)
/* Display a constructor. Works recursively for array constructors. */
void
gfc_show_constructor (gfc_constructor * c)
gfc_show_constructor (gfc_constructor *c)
{
for (; c; c = c->next)
{
if (c->iterator == NULL)
......@@ -297,7 +294,7 @@ gfc_show_constructor (gfc_constructor * c)
/* Show an expression. */
void
gfc_show_expr (gfc_expr * p)
gfc_show_expr (gfc_expr *p)
{
const char *c;
int i;
......@@ -530,7 +527,7 @@ gfc_show_expr (gfc_expr * p)
whatever single bit attributes are present. */
void
gfc_show_attr (symbol_attribute * attr)
gfc_show_attr (symbol_attribute *attr)
{
gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
......@@ -601,7 +598,7 @@ gfc_show_attr (symbol_attribute * attr)
/* Show components of a derived type. */
void
gfc_show_components (gfc_symbol * sym)
gfc_show_components (gfc_symbol *sym)
{
gfc_component *c;
......@@ -628,7 +625,7 @@ gfc_show_components (gfc_symbol * sym)
that symbol. */
void
gfc_show_symbol (gfc_symbol * sym)
gfc_show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
......@@ -683,12 +680,12 @@ gfc_show_symbol (gfc_symbol * sym)
gfc_status ("Formal arglist:");
for (formal = sym->formal; formal; formal = formal->next)
{
if (formal->sym != NULL)
gfc_status (" %s", formal->sym->name);
else
gfc_status (" [Alt Return]");
}
{
if (formal->sym != NULL)
gfc_status (" %s", formal->sym->name);
else
gfc_status (" [Alt Return]");
}
}
if (sym->formal_ns)
......@@ -706,7 +703,7 @@ gfc_show_symbol (gfc_symbol * sym)
and the name of the associated subroutine, really. */
static void
show_uop (gfc_user_op * uop)
show_uop (gfc_user_op *uop)
{
gfc_interface *intr;
......@@ -721,9 +718,8 @@ show_uop (gfc_user_op * uop)
/* Workhorse function for traversing the user operator symtree. */
static void
traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
{
if (st == NULL)
return;
......@@ -737,9 +733,8 @@ traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
/* Traverse the tree of user operator nodes. */
void
gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
{
traverse_uop (ns->uop_root, func);
}
......@@ -747,7 +742,7 @@ gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
/* Function to display a common block. */
static void
show_common (gfc_symtree * st)
show_common (gfc_symtree *st)
{
gfc_symbol *s;
......@@ -769,9 +764,8 @@ show_common (gfc_symtree * st)
/* Worker function to display the symbol tree. */
static void
show_symtree (gfc_symtree * st)
show_symtree (gfc_symtree *st)
{
show_indent ();
gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
......@@ -786,15 +780,14 @@ show_symtree (gfc_symtree * st)
static void gfc_show_code_node (int level, gfc_code * c);
static void gfc_show_code_node (int, gfc_code *);
/* Show a list of code structures. Mutually recursive with
gfc_show_code_node(). */
void
gfc_show_code (int level, gfc_code * c)
gfc_show_code (int level, gfc_code *c)
{
for (; c; c = c->next)
gfc_show_code_node (level, c);
}
......@@ -811,7 +804,7 @@ gfc_show_namelist (gfc_namelist *n)
if necessary. */
static void
gfc_show_omp_node (int level, gfc_code * c)
gfc_show_omp_node (int level, gfc_code *c)
{
gfc_omp_clauses *omp_clauses = NULL;
const char *name = NULL;
......@@ -996,10 +989,11 @@ gfc_show_omp_node (int level, gfc_code * c)
gfc_status (" (%s)", c->ext.omp_name);
}
/* Show a single code node and everything underneath it if necessary. */
static void
gfc_show_code_node (int level, gfc_code * c)
gfc_show_code_node (int level, gfc_code *c)
{
gfc_forall_iterator *fa;
gfc_open *open;
......@@ -1051,24 +1045,24 @@ gfc_show_code_node (int level, gfc_code * c)
case EXEC_GOTO:
gfc_status ("GOTO ");
if (c->label)
gfc_status ("%d", c->label->value);
gfc_status ("%d", c->label->value);
else
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
break;
case EXEC_CALL:
......@@ -1092,9 +1086,9 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("PAUSE ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
gfc_status ("%d", c->ext.stop_code);
break;
......@@ -1102,9 +1096,9 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("STOP ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
gfc_status ("%d", c->ext.stop_code);
break;
......@@ -1709,7 +1703,7 @@ gfc_show_equiv (gfc_equiv *eq)
/* Show a freakin' whole namespace. */
void
gfc_show_namespace (gfc_namespace * ns)
gfc_show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
......
gcc/fortran/error.c
/* Handle errors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Niels Kristian Bech Jensen
This file is part of GCC.
......@@ -69,12 +69,10 @@ error_char (char c)
{
if (cur_error_buffer->index >= cur_error_buffer->allocated)
{
cur_error_buffer->allocated =
cur_error_buffer->allocated
? cur_error_buffer->allocated * 2 : 1000;
cur_error_buffer->message
= xrealloc (cur_error_buffer->message,
cur_error_buffer->allocated);
cur_error_buffer->allocated = cur_error_buffer->allocated
? cur_error_buffer->allocated * 2 : 1000;
cur_error_buffer->message = xrealloc (cur_error_buffer->message,
cur_error_buffer->allocated);
}
cur_error_buffer->message[cur_error_buffer->index++] = c;
}
......@@ -152,7 +150,7 @@ error_integer (int i)
static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
static void
show_locus (locus * loc, int c1, int c2)
show_locus (locus *loc, int c1, int c2)
{
gfc_linebuf *lb;
gfc_file *f;
......@@ -308,7 +306,7 @@ show_locus (locus * loc, int c1, int c2)
loci may or may not be on the same source line. */
static void
show_loci (locus * l1, locus * l2)
show_loci (locus *l1, locus *l2)
{
int m, c1, c2;
......@@ -349,7 +347,6 @@ show_loci (locus * l1, locus * l2)
show_locus (l1, c1, c2);
return;
}
......@@ -545,10 +542,10 @@ error_print (const char *type, const char *format0, va_list argp)
}
format++;
if (ISDIGIT(*format))
if (ISDIGIT (*format))
{
/* This is a position specifier. See comment above. */
while (ISDIGIT(*format))
while (ISDIGIT (*format))
format++;
/* Skip over the dollar sign. */
......@@ -663,17 +660,15 @@ gfc_notify_std (int std, const char *nocmsgid, ...)
va_list argp;
bool warning;
warning = ((gfc_option.warn_std & std) != 0)
&& !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0
&& !warning)
warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0 && !warning)
return SUCCESS;
if (gfc_suppress_error)
return warning ? SUCCESS : FAILURE;
cur_error_buffer = (warning && !warnings_are_errors)
? &warning_buffer : &error_buffer;
? &warning_buffer : &error_buffer;
cur_error_buffer->flag = 1;
cur_error_buffer->index = 0;
......@@ -889,7 +884,7 @@ gfc_error_check (void)
/* Save the existing error state. */
void
gfc_push_error (gfc_error_buf * err)
gfc_push_error (gfc_error_buf *err)
{
err->flag = error_buffer.flag;
if (error_buffer.flag)
......@@ -902,7 +897,7 @@ gfc_push_error (gfc_error_buf * err)
/* Restore a previous pushed error state. */
void
gfc_pop_error (gfc_error_buf * err)
gfc_pop_error (gfc_error_buf *err)
{
error_buffer.flag = err->flag;
if (error_buffer.flag)
......@@ -918,7 +913,7 @@ gfc_pop_error (gfc_error_buf * err)
/* Free a pushed error state, but keep the current error state. */
void
gfc_free_error (gfc_error_buf * err)
gfc_free_error (gfc_error_buf *err)
{
if (err->flag)
gfc_free (err->message);
......
gcc/fortran/expr.c
/* Routines for manipulation of expression nodes.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
......@@ -34,7 +34,6 @@ gfc_get_expr (void)
gfc_expr *e;
e = gfc_getmem (sizeof (gfc_expr));
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
......@@ -47,7 +46,7 @@ gfc_get_expr (void)
/* Free an argument list and everything below it. */
void
gfc_free_actual_arglist (gfc_actual_arglist * a1)
gfc_free_actual_arglist (gfc_actual_arglist *a1)
{
gfc_actual_arglist *a2;
......@@ -64,7 +63,7 @@ gfc_free_actual_arglist (gfc_actual_arglist * a1)
/* Copy an arglist structure and all of the arguments. */
gfc_actual_arglist *
gfc_copy_actual_arglist (gfc_actual_arglist * p)
gfc_copy_actual_arglist (gfc_actual_arglist *p)
{
gfc_actual_arglist *head, *tail, *new;
......@@ -93,7 +92,7 @@ gfc_copy_actual_arglist (gfc_actual_arglist * p)
/* Free a list of reference structures. */
void
gfc_free_ref_list (gfc_ref * p)
gfc_free_ref_list (gfc_ref *p)
{
gfc_ref *q;
int i;
......@@ -134,7 +133,7 @@ gfc_free_ref_list (gfc_ref * p)
something else or the expression node belongs to another structure. */
static void
free_expr0 (gfc_expr * e)
free_expr0 (gfc_expr *e)
{
int n;
......@@ -221,9 +220,8 @@ free_expr0 (gfc_expr * e)
/* Free an expression node and everything beneath it. */
void
gfc_free_expr (gfc_expr * e)
gfc_free_expr (gfc_expr *e)
{
if (e == NULL)
return;
if (e->con_by_offset)
......@@ -236,12 +234,10 @@ gfc_free_expr (gfc_expr * e)
/* Graft the *src expression onto the *dest subexpression. */
void
gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
{
free_expr0 (dest);
*dest = *src;
gfc_free (src);
}
......@@ -252,9 +248,8 @@ gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
failure is OK for some callers. */
const char *
gfc_extract_int (gfc_expr * expr, int *result)
gfc_extract_int (gfc_expr *expr, int *result)
{
if (expr->expr_type != EXPR_CONSTANT)
return _("Constant expression required at %C");
......@@ -276,7 +271,7 @@ gfc_extract_int (gfc_expr * expr, int *result)
/* Recursively copy a list of reference structures. */
static gfc_ref *
copy_ref (gfc_ref * src)
copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
......@@ -312,13 +307,12 @@ copy_ref (gfc_ref * src)
}
/* Detect whether an expression has any vector index array
references. */
/* Detect whether an expression has any vector index array references. */
int
gfc_has_vector_index (gfc_expr *e)
{
gfc_ref * ref;
gfc_ref *ref;
int i;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
......@@ -332,7 +326,7 @@ gfc_has_vector_index (gfc_expr *e)
/* Copy a shape array. */
mpz_t *
gfc_copy_shape (mpz_t * shape, int rank)
gfc_copy_shape (mpz_t *shape, int rank)
{
mpz_t *new_shape;
int n;
......@@ -363,7 +357,7 @@ gfc_copy_shape (mpz_t * shape, int rank)
*/
mpz_t *
gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
{
mpz_t *new_shape, *s;
int i, n;
......@@ -380,12 +374,12 @@ gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
if (n < 0 || n >= rank)
return NULL;
s = new_shape = gfc_get_shape (rank-1);
s = new_shape = gfc_get_shape (rank - 1);
for (i = 0; i < rank; i++)
{
if (i == n)
continue;
continue;
mpz_init_set (*s, shape[i]);
s++;
}
......@@ -393,11 +387,12 @@ gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
return new_shape;
}
/* Given an expression pointer, return a copy of the expression. This
subroutine is recursive. */
gfc_expr *
gfc_copy_expr (gfc_expr * p)
gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
char *s;
......@@ -423,8 +418,7 @@ gfc_copy_expr (gfc_expr * p)
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string,
p->value.character.length + 1);
memcpy (s, p->value.character.string, p->value.character.length + 1);
break;
}
switch (q->ts.type)
......@@ -434,15 +428,15 @@ gfc_copy_expr (gfc_expr * p)
break;
case BT_REAL:
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.real);
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.real);
mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
break;
......@@ -452,8 +446,7 @@ gfc_copy_expr (gfc_expr * p)
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string,
p->value.character.length + 1);
memcpy (s, p->value.character.string, p->value.character.length + 1);
break;
case BT_LOGICAL:
......@@ -512,9 +505,8 @@ gfc_copy_expr (gfc_expr * p)
kind numbers mean more precision for numeric types. */
int
gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
{
return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}
......@@ -524,7 +516,6 @@ gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
static int
numeric_type (bt type)
{
return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}
......@@ -532,9 +523,8 @@ numeric_type (bt type)
/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
int
gfc_numeric_ts (gfc_typespec * ts)
gfc_numeric_ts (gfc_typespec *ts)
{
return numeric_type (ts->type);
}
......@@ -562,7 +552,7 @@ gfc_int_expr (int i)
/* Returns an expression node that is a logical constant. */
gfc_expr *
gfc_logical_expr (int i, locus * where)
gfc_logical_expr (int i, locus *where)
{
gfc_expr *p;
......@@ -586,7 +576,7 @@ gfc_logical_expr (int i, locus * where)
argument list with a NULL pointer terminating the list. */
gfc_expr *
gfc_build_conversion (gfc_expr * e)
gfc_build_conversion (gfc_expr *e)
{
gfc_expr *p;
......@@ -612,7 +602,7 @@ gfc_build_conversion (gfc_expr * e)
1.0**2 stays as it is. */
void
gfc_type_convert_binary (gfc_expr * e)
gfc_type_convert_binary (gfc_expr *e)
{
gfc_expr *op1, *op2;
......@@ -628,10 +618,9 @@ gfc_type_convert_binary (gfc_expr * e)
/* Kind conversions of same type. */
if (op1->ts.type == op2->ts.type)
{
if (op1->ts.kind == op2->ts.kind)
{
/* No type conversions. */
/* No type conversions. */
e->ts = op1->ts;
goto done;
}
......@@ -685,7 +674,7 @@ done:
function expects that the expression has already been simplified. */
int
gfc_is_constant_expr (gfc_expr * e)
gfc_is_constant_expr (gfc_expr *e)
{
gfc_constructor *c;
gfc_actual_arglist *arg;
......@@ -757,7 +746,7 @@ gfc_is_constant_expr (gfc_expr * e)
/* Try to collapse intrinsic expressions. */
static try
simplify_intrinsic_op (gfc_expr * p, int type)
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_expr *op1, *op2, *result;
......@@ -882,9 +871,8 @@ simplify_intrinsic_op (gfc_expr * p, int type)
with gfc_simplify_expr(). */
static try
simplify_constructor (gfc_constructor * c, int type)
simplify_constructor (gfc_constructor *c, int type)
{
for (; c; c = c->next)
{
if (c->iterator
......@@ -904,8 +892,8 @@ simplify_constructor (gfc_constructor * c, int type)
/* Pull a single array element out of an array constructor. */
static try
find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
gfc_constructor ** rval)
find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
gfc_constructor **rval)
{
unsigned long nelemen;
int i;
......@@ -930,10 +918,9 @@ find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
/* Check the bounds. */
if (ar->as->upper[i]
&& (mpz_cmp (e->value.integer,
ar->as->upper[i]->value.integer) > 0
|| mpz_cmp (e->value.integer,
ar->as->lower[i]->value.integer) < 0))
&& (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
|| mpz_cmp (e->value.integer,
ar->as->lower[i]->value.integer) < 0))
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
......@@ -942,8 +929,7 @@ find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
goto depart;
}
mpz_sub (delta, e->value.integer,
ar->as->lower[i]->value.integer);
mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
mpz_add (offset, offset, delta);
}
......@@ -973,7 +959,7 @@ depart:
/* Find a component of a structure constructor. */
static gfc_constructor *
find_component_ref (gfc_constructor * cons, gfc_ref * ref)
find_component_ref (gfc_constructor *cons, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
......@@ -994,7 +980,7 @@ find_component_ref (gfc_constructor * cons, gfc_ref * ref)
the subobject reference in the process. */
static void
remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
{
gfc_expr *e;
......@@ -1075,11 +1061,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
upper = ref->u.ar.as->upper[d];
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
gcc_assert(begin);
gcc_assert(begin->expr_type == EXPR_ARRAY);
gcc_assert(begin->rank == 1);
gcc_assert(begin->shape);
{
gcc_assert (begin);
gcc_assert (begin->expr_type == EXPR_ARRAY);
gcc_assert (begin->rank == 1);
gcc_assert (begin->shape);
vecsub[d] = begin->value.constructor;
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
......@@ -1090,7 +1076,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (c = vecsub[d]; c; c = c->next)
{
if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
|| mpz_cmp (c->expr->value.integer, lower->value.integer) < 0)
|| mpz_cmp (c->expr->value.integer,
lower->value.integer) < 0)
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", d + 1, &ref->u.ar.c_where[d]);
......@@ -1098,12 +1085,12 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
goto cleanup;
}
}
}
}
else
{
{
if ((begin && begin->expr_type != EXPR_CONSTANT)
|| (finish && finish->expr_type != EXPR_CONSTANT)
|| (step && step->expr_type != EXPR_CONSTANT))
|| (finish && finish->expr_type != EXPR_CONSTANT)
|| (step && step->expr_type != EXPR_CONSTANT))
{
t = FAILURE;
goto cleanup;
......@@ -1157,8 +1144,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
mpz_div (tmp_mpz, tmp_mpz, stride[d]);
mpz_mul (nelts, nelts, tmp_mpz);
/* An element reference reduces the rank of the expression; don't add
anything to the shape array. */
/* An element reference reduces the rank of the expression; don't
add anything to the shape array. */
if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
mpz_set (expr->shape[shape_i++], tmp_mpz);
}
......@@ -1178,7 +1165,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
/* Now clock through the array reference, calculating the index in
the source constructor and transferring the elements to the new
constructor. */
for (idx = 0; idx < (int)mpz_get_si (nelts); idx++)
for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
{
if (ref->u.ar.offset)
mpz_set (ptr, ref->u.ar.offset->value.integer);
......@@ -1189,14 +1176,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (d = 0; d < rank; d++)
{
mpz_set (tmp_mpz, ctr[d]);
mpz_sub (tmp_mpz, tmp_mpz,
ref->u.ar.as->lower[d]->value.integer);
mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
mpz_add (ptr, ptr, tmp_mpz);
if (!incr_ctr) continue;
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
gcc_assert(vecsub[d]);
......@@ -1213,9 +1199,9 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
{
mpz_add (ctr[d], ctr[d], stride[d]);
if (mpz_cmp_ui (stride[d], 0) > 0 ?
mpz_cmp (ctr[d], end[d]) > 0 :
mpz_cmp (ctr[d], end[d]) < 0)
if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0
: mpz_cmp (ctr[d], end[d]) < 0)
mpz_set (ctr[d], start[d]);
else
incr_ctr = false;
......@@ -1269,13 +1255,13 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
char *chr;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
return FAILURE;
*newp = gfc_copy_expr (p);
chr = p->value.character.string;
end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer);
start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer);
end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
(*newp)->value.character.length = end - start + 1;
strncpy ((*newp)->value.character.string, &chr[start - 1],
......@@ -1289,7 +1275,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
parameter variable values are substituted. */
static try
simplify_const_ref (gfc_expr * p)
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons;
gfc_expr *newp;
......@@ -1302,8 +1288,7 @@ simplify_const_ref (gfc_expr * p)
switch (p->ref->u.ar.type)
{
case AR_ELEMENT:
if (find_array_element (p->value.constructor,
&p->ref->u.ar,
if (find_array_element (p->value.constructor, &p->ref->u.ar,
&cons) == FAILURE)
return FAILURE;
......@@ -1322,7 +1307,7 @@ simplify_const_ref (gfc_expr * p)
case AR_FULL:
if (p->ref->next != NULL
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
cons = p->value.constructor;
for (; cons; cons = cons->next)
......@@ -1364,7 +1349,7 @@ simplify_const_ref (gfc_expr * p)
/* Simplify a chain of references. */
static try
simplify_ref_chain (gfc_ref * ref, int type)
simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
......@@ -1375,16 +1360,12 @@ simplify_ref_chain (gfc_ref * ref, int type)
case REF_ARRAY:
for (n = 0; n < ref->u.ar.dimen; n++)
{
if (gfc_simplify_expr (ref->u.ar.start[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (ref->u.ar.end[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (ref->u.ar.stride[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
return FAILURE;
}
break;
......@@ -1405,7 +1386,7 @@ simplify_ref_chain (gfc_ref * ref, int type)
/* Try to substitute the value of a parameter variable. */
static try
simplify_parameter_variable (gfc_expr * p, int type)
simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
try t;
......@@ -1423,7 +1404,7 @@ simplify_parameter_variable (gfc_expr * p, int type)
/* Only use the simplification if it eliminated all subobject
references. */
if (t == SUCCESS && ! e->ref)
if (t == SUCCESS && !e->ref)
gfc_replace_expr (p, e);
else
gfc_free_expr (e);
......@@ -1446,12 +1427,12 @@ simplify_parameter_variable (gfc_expr * p, int type)
The expression type is defined for:
0 Basic expression parsing
1 Simplifying array constructors -- will substitute
iterator values.
iterator values.
Returns FAILURE on error, SUCCESS otherwise.
NOTE: Will return SUCCESS even if the expression can not be simplified. */
try
gfc_simplify_expr (gfc_expr * p, int type)
gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
......@@ -1489,7 +1470,7 @@ gfc_simplify_expr (gfc_expr * p, int type)
gfc_extract_int (p->ref->u.ss.end, &end);
s = gfc_getmem (end - start + 2);
memcpy (s, p->value.character.string + start, end - start);
s[end-start+1] = '\0'; /* TODO: C-style string for debugging. */
s[end - start + 1] = '\0'; /* TODO: C-style string. */
gfc_free (p->value.character.string);
p->value.character.string = s;
p->value.character.length = end - start;
......@@ -1510,7 +1491,7 @@ gfc_simplify_expr (gfc_expr * p, int type)
case EXPR_VARIABLE:
/* Only substitute array parameter variables if we are in an
initialization expression, or we want a subsection. */
initialization expression, or we want a subsection. */
if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
&& (gfc_init_expr || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
......@@ -1539,9 +1520,8 @@ gfc_simplify_expr (gfc_expr * p, int type)
if (simplify_constructor (p->value.constructor, type) == FAILURE)
return FAILURE;
if (p->expr_type == EXPR_ARRAY
&& p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
gfc_expand_constructor (p);
if (simplify_const_ref (p) == FAILURE)
......@@ -1559,9 +1539,8 @@ gfc_simplify_expr (gfc_expr * p, int type)
be declared as. */
static bt
et0 (gfc_expr * e)
et0 (gfc_expr *e)
{
if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
return BT_INTEGER;
......@@ -1575,7 +1554,7 @@ et0 (gfc_expr * e)
static try check_init_expr (gfc_expr *);
static try
check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
......@@ -1605,7 +1584,7 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
{
gfc_error ("Numeric or CHARACTER operands are required in "
"expression at %L", &e->where);
return FAILURE;
return FAILURE;
}
break;
......@@ -1703,7 +1682,7 @@ not_numeric:
this problem here. */
static try
check_inquiry (gfc_expr * e, int not_restricted)
check_inquiry (gfc_expr *e, int not_restricted)
{
const char *name;
......@@ -1743,7 +1722,7 @@ check_inquiry (gfc_expr * e, int not_restricted)
{
if (e->symtree->n.sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
== FAILURE)
== FAILURE)
return FAILURE;
e->ts = e->symtree->n.sym->ts;
......@@ -1752,8 +1731,8 @@ check_inquiry (gfc_expr * e, int not_restricted)
/* Assumed character length will not reduce to a constant expression
with LEN, as required by the standard. */
if (i == 4 && not_restricted
&& e->symtree->n.sym->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.cl->length == NULL)
&& e->symtree->n.sym->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.cl->length == NULL)
gfc_notify_std (GFC_STD_GNU, "assumed character length "
"variable '%s' in constant expression at %L",
e->symtree->n.sym->name, &e->where);
......@@ -1770,7 +1749,7 @@ check_inquiry (gfc_expr * e, int not_restricted)
FAILURE is returned an error message has been generated. */
static try
check_init_expr (gfc_expr * e)
check_init_expr (gfc_expr *e)
{
gfc_actual_arglist *ap;
match m;
......@@ -1809,7 +1788,7 @@ check_init_expr (gfc_expr * e)
if (m == MATCH_NO)
gfc_error ("Function '%s' in initialization expression at %L "
"must be an intrinsic function",
e->symtree->n.sym->name, &e->where);
e->symtree->n.sym->name, &e->where);
if (m != MATCH_YES)
t = FAILURE;
......@@ -1882,7 +1861,7 @@ check_init_expr (gfc_expr * e)
expression, then reducing it to a constant. */
match
gfc_match_init_expr (gfc_expr ** result)
gfc_match_init_expr (gfc_expr **result)
{
gfc_expr *expr;
match m;
......@@ -1914,9 +1893,8 @@ gfc_match_init_expr (gfc_expr ** result)
/* Not all inquiry functions are simplified to constant expressions
so it is necessary to call check_inquiry again. */
if (!gfc_is_constant_expr (expr)
&& check_inquiry (expr, 1) == FAILURE
&& !gfc_in_match_data ())
if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) == FAILURE
&& !gfc_in_match_data ())
{
gfc_error ("Initialization expression didn't reduce %C");
return MATCH_ERROR;
......@@ -1928,7 +1906,6 @@ gfc_match_init_expr (gfc_expr ** result)
}
static try check_restricted (gfc_expr *);
/* Given an actual argument list, test to see that each argument is a
......@@ -1936,7 +1913,7 @@ static try check_restricted (gfc_expr *);
integer or character. */
static try
restricted_args (gfc_actual_arglist * a)
restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
{
......@@ -1954,7 +1931,7 @@ restricted_args (gfc_actual_arglist * a)
/* Make sure a non-intrinsic function is a specification function. */
static try
external_spec_function (gfc_expr * e)
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
......@@ -1996,7 +1973,7 @@ external_spec_function (gfc_expr * e)
restricted expression. */
static try
restricted_intrinsic (gfc_expr * e)
restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
if (check_inquiry (e, 0) == SUCCESS)
......@@ -2011,7 +1988,7 @@ restricted_intrinsic (gfc_expr * e)
return FAILURE. */
static try
check_restricted (gfc_expr * e)
check_restricted (gfc_expr *e)
{
gfc_symbol *sym;
try t;
......@@ -2029,8 +2006,8 @@ check_restricted (gfc_expr * e)
break;
case EXPR_FUNCTION:
t = e->value.function.esym ?
external_spec_function (e) : restricted_intrinsic (e);
t = e->value.function.esym ? external_spec_function (e)
: restricted_intrinsic (e);
break;
......@@ -2052,10 +2029,11 @@ check_restricted (gfc_expr * e)
break;
}
/* gfc_is_formal_arg broadcasts that a formal argument list is being processed
in resolve.c(resolve_formal_arglist). This is done so that host associated
dummy array indices are accepted (PR23446). This mechanism also does the
same for the specification expressions of array-valued functions. */
/* gfc_is_formal_arg broadcasts that a formal argument list is being
processed in resolve.c(resolve_formal_arglist). This is done so
that host associated dummy array indices are accepted (PR23446).
This mechanism also does the same for the specification expressions
of array-valued functions. */
if (sym->attr.in_common
|| sym->attr.use_assoc
|| sym->attr.dummy
......@@ -2109,7 +2087,7 @@ check_restricted (gfc_expr * e)
we return FAILURE, an error has been generated. */
try
gfc_specification_expr (gfc_expr * e)
gfc_specification_expr (gfc_expr *e)
{
if (e == NULL)
return SUCCESS;
......@@ -2138,8 +2116,7 @@ gfc_specification_expr (gfc_expr * e)
/* Given two expressions, make sure that the arrays are conformable. */
try
gfc_check_conformance (const char *optype_msgid,
gfc_expr * op1, gfc_expr * op2)
gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
......@@ -2189,7 +2166,7 @@ gfc_check_conformance (const char *optype_msgid,
sure that the assignment can take place. */
try
gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
gfc_ref *ref;
......@@ -2219,10 +2196,9 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
function is terminated.....
Therefore, the left hand side is no longer a varaiable, when it is:*/
if (sym->attr.flavor == FL_PROCEDURE
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.external)
Therefore, the left hand side is no longer a varaiable, when it is: */
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.external)
{
bool bad_proc;
bad_proc = false;
......@@ -2237,10 +2213,10 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
/* (iii) A module or internal procedure.... */
if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
&& gfc_current_ns->parent
&& (!(gfc_current_ns->parent->proc_name->attr.function
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
/* .... that is not a function.... */
......@@ -2285,8 +2261,8 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
&& lvalue->ref->u.ar.type == AR_FULL
&& lvalue->ref->u.ar.as->cp_was_assumed)
{
gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
" is illegal", &lvalue->where);
gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
"is illegal", &lvalue->where);
return FAILURE;
}
......@@ -2332,7 +2308,7 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
NULLIFY statement. */
try
gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
gfc_ref *ref;
......@@ -2347,7 +2323,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
}
if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& lvalue->symtree->n.sym->attr.use_assoc)
&& lvalue->symtree->n.sym->attr.use_assoc)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
......@@ -2364,16 +2340,16 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (pointer)
check_intent_in = 0;
check_intent_in = 0;
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
pointer = 1;
pointer = 1;
}
if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
lvalue->symtree->n.sym->name, &lvalue->where);
return FAILURE;
}
......@@ -2387,8 +2363,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
{
gfc_error ("Bad pointer object in PURE procedure at %L",
&lvalue->where);
gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
return FAILURE;
}
......@@ -2415,7 +2390,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (lvalue->rank != rvalue->rank)
{
gfc_error ("Different ranks in pointer assignment at %L",
&lvalue->where);
&lvalue->where);
return FAILURE;
}
......@@ -2424,9 +2399,9 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
return SUCCESS;
if (lvalue->ts.type == BT_CHARACTER
&& lvalue->ts.cl->length && rvalue->ts.cl->length
&& abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
rvalue->ts.cl->length)) == 1)
&& lvalue->ts.cl->length && rvalue->ts.cl->length
&& abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
rvalue->ts.cl->length)) == 1)
{
gfc_error ("Different character lengths in pointer "
"assignment at %L", &lvalue->where);
......@@ -2457,7 +2432,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (attr.protected && attr.use_assoc)
{
gfc_error ("Pointer assigment target has PROTECTED "
"attribute at %L", &rvalue->where);
"attribute at %L", &rvalue->where);
return FAILURE;
}
......@@ -2469,7 +2444,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
symbol. Used for initialization assignments. */
try
gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
gfc_expr lvalue;
try r;
......@@ -2480,7 +2455,7 @@ gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
lvalue.ts = sym->ts;
if (sym->as)
lvalue.rank = sym->as->rank;
lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
......@@ -2510,7 +2485,7 @@ gfc_default_initializer (gfc_typespec *ts)
for (c = ts->derived->components; c; c = c->next)
{
if ((c->initializer || c->allocatable) && init == NULL)
init = gfc_get_expr ();
init = gfc_get_expr ();
}
if (init == NULL)
......@@ -2524,15 +2499,15 @@ gfc_default_initializer (gfc_typespec *ts)
for (c = ts->derived->components; c; c = c->next)
{
if (tail == NULL)
init->value.constructor = tail = gfc_get_constructor ();
init->value.constructor = tail = gfc_get_constructor ();
else
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
if (c->initializer)
tail->expr = gfc_copy_expr (c->initializer);
tail->expr = gfc_copy_expr (c->initializer);
if (c->allocatable)
{
......@@ -2550,7 +2525,7 @@ gfc_default_initializer (gfc_typespec *ts)
whole array. */
gfc_expr *
gfc_get_variable_expr (gfc_symtree * var)
gfc_get_variable_expr (gfc_symtree *var)
{
gfc_expr *e;
......@@ -2574,7 +2549,7 @@ gfc_get_variable_expr (gfc_symtree * var)
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
void
gfc_expr_set_symbols_referenced (gfc_expr * expr)
gfc_expr_set_symbols_referenced (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
......@@ -2592,7 +2567,7 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
case EXPR_FUNCTION:
for (arg = expr->value.function.actual; arg; arg = arg->next)
gfc_expr_set_symbols_referenced (arg->expr);
gfc_expr_set_symbols_referenced (arg->expr);
break;
case EXPR_VARIABLE:
......@@ -2607,7 +2582,7 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
case EXPR_STRUCTURE:
case EXPR_ARRAY:
for (c = expr->value.constructor; c; c = c->next)
gfc_expr_set_symbols_referenced (c->expr);
gfc_expr_set_symbols_referenced (c->expr);
break;
default:
......@@ -2617,26 +2592,26 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
}
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
gfc_expr_set_symbols_referenced (ref->u.ss.start);
gfc_expr_set_symbols_referenced (ref->u.ss.end);
break;
default:
gcc_unreachable ();
break;
}
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
}
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
gfc_expr_set_symbols_referenced (ref->u.ss.start);
gfc_expr_set_symbols_referenced (ref->u.ss.end);
break;
default:
gcc_unreachable ();
break;
}
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment