aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/decl.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/decl.c')
-rw-r--r--gcc/fortran/decl.c530
1 files changed, 249 insertions, 281 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b2f401f..2470722 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1,5 +1,6 @@
/* 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;
generated by cgit v1.1 at 2024-11-05 14:00:52 +0000