+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.
/* 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.
In expr.c: expand_expr, for operands of a MULT_EXPR.
In fold-const.c: fold.
In tree.c: get_narrower and get_unwidened. */
-\f
+
/* Subroutines of `convert'. */
-\f
/* Create an expression whose value is that of 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
/* 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.
/* 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. */
/* 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;
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);
}
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;
for (; con; con = con->next)
{
if (com == con->n.component)
- return con;
+ return con;
}
return NULL;
}
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;
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;
}
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;
}
/* 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
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;
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);
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;
/* 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;
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
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);
}
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;
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;
}
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);
}
/* 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.
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. */
/* 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;
gfc_free_expr (p->expr);
gfc_free_iterator (&p->iter, 0);
free_variable (p->list);
-
gfc_free (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;
/* 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)
{
parenthesis. */
static match
-var_list (gfc_data_variable * parent)
+var_list (gfc_data_variable *parent)
{
gfc_data_variable *tail, var;
match m;
variable-iterator list. */
static match
-var_element (gfc_data_variable * new)
+var_element (gfc_data_variable *new)
{
match m;
gfc_symbol *sym;
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);
}
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)
/* 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;
static match
-match_data_constant (gfc_expr ** result)
+match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
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;
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
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;
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr ** expr)
+match_char_length (gfc_expr **expr)
{
int length;
match m;
(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
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)
{
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;
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);
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);
}
/* 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;
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, ¤t_ts))
+ && (sym->attr.implicit_type == 0
+ || !gfc_compare_types (&sym->ts, ¤t_ts))
&& gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
return FAILURE;
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);
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);
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);
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;
}
}
/* 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;
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;
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;
}
{
/* 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. */
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;
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)
{
{
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;
}
}
/* 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;
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;
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);
{
if (gfc_match (" =>") == MATCH_YES)
{
-
if (!current_attr.pointer)
{
gfc_error ("Initialization at %C isn't for a pointer variable");
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;
}
{
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;
}
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;
}
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;
}
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. */
else
{
if (current_ts.type == BT_DERIVED
- && !current_attr.pointer
- && !initializer)
+ && !current_attr.pointer && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
/* 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;
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;
}
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;
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;
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);
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;
{
c = gfc_peek_char();
if (!gfc_is_whitespace(c) && c != '*' && c != '('
- && c != ':' && c != ',')
+ && c != ':' && c != ',')
return MATCH_NO;
}
match
gfc_match_implicit_none (void)
{
-
return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
}
}
/* 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;
}
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;
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(;;)
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;
static match
match_attr_spec (void)
{
-
/* Modifiers that can exist in a type statement. */
typedef enum
{ GFC_DECL_BEGIN = 0,
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;
{
t = gfc_add_flavor (¤t_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
{
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]);
}
if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
- && gfc_current_state () != COMP_MODULE)
+ && gfc_current_state () != COMP_MODULE)
{
if (d == DECL_PRIVATE)
attr = "PRIVATE";
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
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
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
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;
}
returned (the null string was matched). */
static match
-match_prefix (gfc_typespec * ts)
+match_prefix (gfc_typespec *ts)
{
int seen_type;
/* 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;
/* 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];
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))
}
/* 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)
{
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;
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;
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;
}
if (m == MATCH_NO)
{
gfc_error ("Expected formal argument list in function "
- "definition at %C");
+ "definition at %C");
m = MATCH_ERROR;
goto cleanup;
}
|| 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));
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
{
return false;
}
+
/* Match an ENTRY statement. */
match
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");
}
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
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;
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;
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;
}
}
+
/* 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;
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)
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;
}
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, ¤t_attr, NULL) == FAILURE)
{
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)
{
}
-
match
gfc_match_intent (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 ();
match
gfc_match_allocatable (void)
{
-
gfc_clear_attr (¤t_attr);
current_attr.allocatable = 1;
match
gfc_match_dimension (void)
{
-
gfc_clear_attr (¤t_attr);
current_attr.dimension = 1;
match
gfc_match_target (void)
{
-
gfc_clear_attr (¤t_attr);
current_attr.target = 1;
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;
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;
}
}
- 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;
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;
}
-
/* 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)
match
-gfc_match_public (gfc_statement * st)
+gfc_match_public (gfc_statement *st)
{
if (gfc_match ("public") != MATCH_YES)
{
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;
}
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;
}
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;
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;
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;
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;
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;
|| 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;
}
{
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;
}
|| 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;
}
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;
}
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;
/* 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.
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"
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);
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;
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
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;
}
/* 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
}
/* 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
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;
}
/* 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
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;
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;
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;
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);
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)
{
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;
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;
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
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;
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;
}
/* 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;
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);
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);
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. */
/* 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;
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;
/* 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;
/* 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)
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;
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. */
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
fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
: GFC_DEP_OVERLAP;
else
- return 1;
+ return 1;
break;
}
/* 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.
/* 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;
/* 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)
/* 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)
/* 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;
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);
/* 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)
{
/* 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)
/* Show an expression. */
void
-gfc_show_expr (gfc_expr * p)
+gfc_show_expr (gfc_expr *p)
{
const char *c;
int i;
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),
/* Show components of a derived type. */
void
-gfc_show_components (gfc_symbol * sym)
+gfc_show_components (gfc_symbol *sym)
{
gfc_component *c;
that symbol. */
void
-gfc_show_symbol (gfc_symbol * sym)
+gfc_show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
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)
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;
/* 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;
/* 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);
}
/* Function to display a common block. */
static void
-show_common (gfc_symtree * st)
+show_common (gfc_symtree *st)
{
gfc_symbol *s;
/* 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);
-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);
}
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;
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;
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:
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;
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;
/* Show a freakin' whole namespace. */
void
-gfc_show_namespace (gfc_namespace * ns)
+gfc_show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
/* 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.
{
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;
}
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;
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;
show_locus (l1, c1, c2);
return;
-
}
}
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. */
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;
/* 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)
/* 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)
/* 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);
/* 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.
gfc_expr *e;
e = gfc_getmem (sizeof (gfc_expr));
-
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
/* 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;
/* 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;
/* 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;
something else or the expression node belongs to another structure. */
static void
-free_expr0 (gfc_expr * e)
+free_expr0 (gfc_expr *e)
{
int n;
/* 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)
/* 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);
}
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");
/* 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;
}
-/* 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)
/* 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;
*/
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;
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++;
}
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;
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)
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;
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:
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;
}
static int
numeric_type (bt type)
{
-
return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}
/* 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);
}
/* 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;
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;
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;
/* 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;
}
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;
/* 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;
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
/* 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;
/* 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]);
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);
}
/* 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;
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;
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);
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]);
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;
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);
}
/* 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);
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]);
{
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;
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],
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;
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;
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)
/* 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;
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;
/* 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;
/* 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);
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;
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;
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))
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)
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;
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;
{
gfc_error ("Numeric or CHARACTER operands are required in "
"expression at %L", &e->where);
- return FAILURE;
+ return FAILURE;
}
break;
this problem here. */
static try
-check_inquiry (gfc_expr * e, int not_restricted)
+check_inquiry (gfc_expr *e, int not_restricted)
{
const char *name;
{
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;
/* 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);
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;
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;
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;
/* 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;
}
-
static try check_restricted (gfc_expr *);
/* Given an actual argument list, test to see that each argument is a
integer or character. */
static try
-restricted_args (gfc_actual_arglist * a)
+restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
{
/* 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;
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)
return FAILURE. */
static try
-check_restricted (gfc_expr * e)
+check_restricted (gfc_expr *e)
{
gfc_symbol *sym;
try t;
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;
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
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;
/* 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;
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;
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;
/* (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.... */
&& 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;
}
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;
}
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",
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;
}
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;
}
if (lvalue->rank != rvalue->rank)
{
gfc_error ("Different ranks in pointer assignment at %L",
- &lvalue->where);
+ &lvalue->where);
return FAILURE;
}
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);
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;
}
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;
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;
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)
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)
{
whole array. */
gfc_expr *
-gfc_get_variable_expr (gfc_symtree * var)
+gfc_get_variable_expr (gfc_symtree *var)
{
gfc_expr *e;
/* 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;
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:
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:
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;
+ }
}
OSDN Git Service
