/* Declaration statement matcher
- Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+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"
-#include <string.h>
-/* This flag is set if a an old-style length selector is matched
+/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
static int old_char_selector;
-/* When variables aquire types and attributes from a declaration
+/* When variables acquire types and attributes from a declaration
statement, they get them from the following static variables. The
first part of a declaration sets these variables and the second
part copies these into symbol structures. */
static gfc_array_spec *current_as;
static int colon_seen;
+/* Initializer of the previous enumerator. */
+
+static gfc_expr *last_initializer;
+
+/* History of all the enumerators is maintained, so that
+ kind values of all the enumerators could be updated depending
+ upon the maximum initialized value. */
+
+typedef struct enumerator_history
+{
+ gfc_symbol *sym;
+ gfc_expr *initializer;
+ struct enumerator_history *next;
+}
+enumerator_history;
+
+/* Header of enum history chain. */
+
+static enumerator_history *enum_history = NULL;
+
+/* Pointer of enum history node containing largest initializer. */
+
+static enumerator_history *max_enum = NULL;
+
/* gfc_new_block points to the symbol of a newly matched block. */
gfc_symbol *gfc_new_block;
+/********************* DATA statement subroutines *********************/
+
+/* Free a gfc_data_variable structure and everything beneath it. */
+
+static void
+free_variable (gfc_data_variable * p)
+{
+ gfc_data_variable *q;
+
+ for (; p; p = q)
+ {
+ q = p->next;
+ 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)
+{
+ gfc_data_value *q;
+
+ for (; p; p = q)
+ {
+ q = p->next;
+ gfc_free_expr (p->expr);
+ gfc_free (p);
+ }
+}
+
+
+/* Free a list of gfc_data structures. */
+
+void
+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);
+ }
+}
+
+
+static match var_element (gfc_data_variable *);
+
+/* Match a list of variables terminated by an iterator and a right
+ parenthesis. */
+
+static match
+var_list (gfc_data_variable * parent)
+{
+ gfc_data_variable *tail, var;
+ match m;
+
+ m = var_element (&var);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ tail = gfc_get_data_variable ();
+ *tail = var;
+
+ parent->list = tail;
+
+ for (;;)
+ {
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_iterator (&parent->iter, 1);
+ if (m == MATCH_YES)
+ break;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ m = var_element (&var);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ tail->next = gfc_get_data_variable ();
+ tail = tail->next;
+
+ *tail = var;
+ }
+
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_DATA);
+ return MATCH_ERROR;
+}
+
+
+/* Match a single element in a data variable list, which can be a
+ variable-iterator list. */
+
+static match
+var_element (gfc_data_variable * new)
+{
+ match m;
+ gfc_symbol *sym;
+
+ memset (new, 0, sizeof (gfc_data_variable));
+
+ if (gfc_match_char ('(') == MATCH_YES)
+ return var_list (new);
+
+ m = gfc_match_variable (&new->expr, 0);
+ if (m != MATCH_YES)
+ return m;
+
+ sym = new->expr->symtree->n.sym;
+
+ 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);
+ return MATCH_ERROR;
+ }
+
+ 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)
+ return MATCH_ERROR;
+
+ if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
+/* Match the top-level list of data variables. */
+
+static match
+top_var_list (gfc_data * d)
+{
+ gfc_data_variable var, *tail, *new;
+ match m;
+
+ tail = NULL;
+
+ for (;;)
+ {
+ m = var_element (&var);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ new = gfc_get_data_variable ();
+ *new = var;
+
+ if (tail == NULL)
+ d->var = new;
+ else
+ tail->next = new;
+
+ tail = new;
+
+ if (gfc_match_char ('/') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_DATA);
+ return MATCH_ERROR;
+}
+
+
+static match
+match_data_constant (gfc_expr ** result)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ gfc_expr *expr;
+ match m;
+
+ m = gfc_match_literal_constant (&expr, 1);
+ if (m == MATCH_YES)
+ {
+ *result = expr;
+ return MATCH_YES;
+ }
+
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ m = gfc_match_null (result);
+ if (m != MATCH_NO)
+ return m;
+
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ return m;
+
+ if (gfc_find_symbol (name, NULL, 1, &sym))
+ return MATCH_ERROR;
+
+ if (sym == NULL
+ || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
+ {
+ gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
+ name);
+ return MATCH_ERROR;
+ }
+ else if (sym->attr.flavor == FL_DERIVED)
+ return gfc_match_structure_constructor (sym, result);
+
+ *result = gfc_copy_expr (sym->value);
+ return MATCH_YES;
+}
+
+
+/* Match a list of values in a DATA statement. The leading '/' has
+ already been seen at this point. */
+
+static match
+top_val_list (gfc_data * data)
+{
+ gfc_data_value *new, *tail;
+ gfc_expr *expr;
+ const char *msg;
+ match m;
+
+ tail = NULL;
+
+ for (;;)
+ {
+ m = match_data_constant (&expr);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ new = gfc_get_data_value ();
+
+ if (tail == NULL)
+ data->value = new;
+ else
+ tail->next = new;
+
+ tail = new;
+
+ if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
+ {
+ tail->expr = expr;
+ tail->repeat = 1;
+ }
+ else
+ {
+ signed int tmp;
+ msg = gfc_extract_int (expr, &tmp);
+ gfc_free_expr (expr);
+ if (msg != NULL)
+ {
+ gfc_error (msg);
+ return MATCH_ERROR;
+ }
+ tail->repeat = tmp;
+
+ m = match_data_constant (&tail->expr);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('/') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') == MATCH_NO)
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_DATA);
+ return MATCH_ERROR;
+}
+
+
+/* Matches an old style initialization. */
+
+static match
+match_old_style_init (const char *name)
+{
+ match m;
+ gfc_symtree *st;
+ gfc_data *newdata;
+
+ /* Set up data structure to hold initializers. */
+ gfc_find_sym_tree (name, NULL, 0, &st);
+
+ newdata = gfc_get_data ();
+ newdata->var = gfc_get_data_variable ();
+ newdata->var->expr = gfc_get_variable_expr (st);
+
+ /* Match initial value list. This also eats the terminal
+ '/'. */
+ m = top_val_list (newdata);
+ if (m != MATCH_YES)
+ {
+ gfc_free (newdata);
+ return m;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Initialization at %C is not allowed in a PURE procedure");
+ gfc_free (newdata);
+ return MATCH_ERROR;
+ }
+
+ /* Chain in namespace list of DATA initializers. */
+ newdata->next = gfc_current_ns->data;
+ gfc_current_ns->data = newdata;
+
+ 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
+ an old-style initialization expression of the form INTEGER I /2/. */
+
+match
+gfc_match_data (void)
+{
+ gfc_data *new;
+ match m;
+
+ for (;;)
+ {
+ new = gfc_get_data ();
+ new->where = gfc_current_locus;
+
+ m = top_var_list (new);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ m = top_val_list (new);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ new->next = gfc_current_ns->data;
+ gfc_current_ns->data = new;
+
+ if (gfc_match_eos () == MATCH_YES)
+ break;
+
+ gfc_match_char (','); /* Optional comma */
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+
+cleanup:
+ gfc_free_data (new);
+ return MATCH_ERROR;
+}
+
+
+/************************ Declaration statements *********************/
+
/* Match an intent specification. Since this can only happen after an
INTENT word, a legal intent-spec must follow. */
if (m != MATCH_YES)
return m;
- m = gfc_match_small_literal_int (&length);
+ m = gfc_match_small_literal_int (&length, NULL);
if (m == MATCH_ERROR)
return m;
}
-/* Special subroutine for finding a symbol. If we're compiling a
- function or subroutine and the parent compilation unit is an
- interface, then check to see if the name we've been given is the
- name of the interface (located in another namespace). If so,
- return that symbol. If not, use gfc_get_symbol(). */
+/* Special subroutine for finding a symbol. Check if the name is found
+ in the current name space. If not, and we're compiling a function or
+ subroutine and the parent compilation unit is an interface, then check
+ to see if the name we've been given is the name of the interface
+ (located in another namespace). */
static int
find_special (const char *name, gfc_symbol ** result)
{
gfc_state_data *s;
+ int i;
+ i = gfc_get_symbol (name, NULL, result);
+ if (i==0)
+ goto end;
+
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
- goto normal;
+ goto end;
s = gfc_state_stack->previous;
if (s == NULL)
- goto normal;
+ goto end;
if (s->state != COMP_INTERFACE)
- goto normal;
+ goto end;
if (s->sym == NULL)
- goto normal; /* Nameless interface */
+ goto end; /* Nameless interface */
if (strcmp (name, s->sym->name) == 0)
{
return 0;
}
-normal:
- return gfc_get_symbol (name, NULL, result);
+end:
+ return i;
}
int rc;
if (gfc_current_ns->parent == NULL)
- return gfc_get_symbol (name, NULL, result);
+ rc = gfc_get_symbol (name, NULL, result);
+ else
+ rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
- rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
- if (*result == NULL)
- return rc;
+ sym = *result;
- /* ??? Deal with ENTRY problem */
+ if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
+ {
+ /* Trap another encompassed procedure with the same name. All
+ these conditions are necessary to avoid picking up an entry
+ whose name clashes with that of the encompassing procedure;
+ this is handled using gsymbols to register unique,globally
+ accessible names. */
+ if (sym->attr.flavor != 0
+ && sym->attr.proc != 0
+ && sym->formal)
+ gfc_error_now ("Procedure '%s' at %C is already defined at %L",
+ name, &sym->declared_at);
+
+ /* Trap declarations of attributes in encompassing scope. The
+ signature for this is that ts.kind is set. Legitimate
+ references only set ts.type. */
+ if (sym->ts.kind != 0
+ && sym->attr.proc == 0
+ && gfc_current_ns->parent != NULL
+ && sym->attr.access == 0)
+ gfc_error_now ("Procedure '%s' at %C has an explicit interface"
+ " and must not have attributes declared at %L",
+ name, &sym->declared_at);
+ }
+
+ if (gfc_current_ns->parent == NULL || *result == NULL)
+ return rc;
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
- sym = *result;
st->n.sym = sym;
sym->refs++;
if (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
rc = 2;
return rc;
symbol_attribute attr;
gfc_symbol *sym;
- if (find_special (name, &sym))
+ /* if (find_special (name, &sym)) */
+ if (gfc_get_symbol (name, NULL, &sym))
return FAILURE;
/* Start updating the symbol table. Add basic type attribute
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)
+{
+ char * s;
+ int slen;
+
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+
+ slen = expr->value.character.length;
+ if (len != slen)
+ {
+ s = gfc_getmem (len);
+ memcpy (s, expr->value.character.string, MIN (len, slen));
+ if (len > slen)
+ memset (&s[slen], ' ', len - slen);
+ gfc_free (expr->value.character.string);
+ expr->value.character.string = s;
+ expr->value.character.length = len;
+ }
+}
+
+
+/* Function to create and update the enumerator history
+ using the information passed as arguments.
+ Pointer "max_enum" is also updated, to point to
+ enum history node containing largest initializer.
+
+ SYM points to the symbol node of enumerator.
+ INIT points to its enumerator value. */
+
+static void
+create_enum_history(gfc_symbol *sym, gfc_expr *init)
+{
+ enumerator_history *new_enum_history;
+ gcc_assert (sym != NULL && init != NULL);
+
+ new_enum_history = gfc_getmem (sizeof (enumerator_history));
+
+ new_enum_history->sym = sym;
+ new_enum_history->initializer = init;
+ new_enum_history->next = NULL;
+
+ if (enum_history == NULL)
+ {
+ enum_history = new_enum_history;
+ max_enum = enum_history;
+ }
+ else
+ {
+ new_enum_history->next = enum_history;
+ enum_history = new_enum_history;
+
+ if (mpz_cmp (max_enum->initializer->value.integer,
+ new_enum_history->initializer->value.integer) < 0)
+ max_enum = new_enum_history;
+ }
+}
+
+
+/* Function to free enum kind history. */
+
+void
+gfc_free_enum_history(void)
+{
+ enumerator_history *current = enum_history;
+ enumerator_history *next;
+
+ while (current != NULL)
+ {
+ next = current->next;
+ gfc_free (current);
+ current = next;
+ }
+ max_enum = NULL;
+ enum_history = NULL;
+}
+
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
return FAILURE;
}
- /* Checking a derived type parameter has to be put off until later. */
+ /* Check if the assignment can happen. This has to be put off
+ until later for a derived type variable. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
+ if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
+ {
+ /* Update symbol character length according initializer. */
+ if (sym->ts.cl->length == NULL)
+ {
+ /* If there are multiple CHARACTER variables declared on
+ the same line, we don't want them to share the same
+ length. */
+ sym->ts.cl = gfc_get_charlen ();
+ sym->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = sym->ts.cl;
+
+ if (init->expr_type == EXPR_CONSTANT)
+ sym->ts.cl->length =
+ gfc_int_expr (init->value.character.length);
+ else if (init->expr_type == EXPR_ARRAY)
+ sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
+ }
+ /* Update initializer character length according symbol. */
+ else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ int len = mpz_get_si (sym->ts.cl->length->value.integer);
+ gfc_constructor * p;
+
+ if (init->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, init);
+ else if (init->expr_type == EXPR_ARRAY)
+ {
+ gfc_free_expr (init->ts.cl->length);
+ init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
+ for (p = init->value.constructor; p; p = p->next)
+ gfc_set_constant_character_len (len, p->expr);
+ }
+ }
+ }
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
init->rank = sym->as->rank;
*initp = NULL;
}
+ /* Maintain enumerator history. */
+ if (gfc_current_state () == COMP_ENUM)
+ create_enum_history (sym, init);
+
return SUCCESS;
}
gfc_intrinsic_symbol (sym);
if (sym->attr.proc != PROC_INTRINSIC
- && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
- || gfc_add_function (&sym->attr, NULL) == FAILURE))
+ && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
+ sym->name, NULL) == FAILURE
+ || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
e = gfc_get_expr ();
symbol table or the current interface. */
static match
-variable_decl (void)
+variable_decl (int elem)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
+ gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
gfc_charlen *cl;
locus var_locus;
match m;
try t;
+ gfc_symbol *sym;
+ locus old_locus;
initializer = NULL;
as = NULL;
+ cp_as = NULL;
+ old_locus = gfc_current_locus;
/* When we get here, we've just matched a list of attributes and
maybe a type and a double colon. The next thing we expect to see
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as);
- if (m == MATCH_ERROR)
+ if (gfc_option.flag_cray_pointer && m == MATCH_YES)
+ cp_as = gfc_copy_array_spec (as);
+ else if (m == MATCH_ERROR)
goto cleanup;
+
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
+ else if (gfc_current_state () == COMP_ENUM)
+ {
+ gfc_error ("Enumerator cannot be array at %C");
+ gfc_free_enum_history ();
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
char_len = NULL;
cl = NULL;
cl->length = char_len;
break;
+ /* Non-constant lengths need to be copied after the first
+ element. */
case MATCH_NO:
- cl = current_ts.cl;
+ if (elem > 1 && current_ts.cl->length
+ && current_ts.cl->length->expr_type != EXPR_CONSTANT)
+ {
+ cl = gfc_get_charlen ();
+ cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = cl;
+ cl->length = gfc_copy_expr (current_ts.cl->length);
+ }
+ else
+ cl = current_ts.cl;
+
break;
case MATCH_ERROR:
goto cleanup;
}
}
-
+
+ /* If this symbol has already shown up in a Cray Pointer declaration,
+ then we want to set the type & bail out. */
+ if (gfc_option.flag_cray_pointer)
+ {
+ gfc_find_symbol (name, gfc_current_ns, 1, &sym);
+ if (sym != NULL && sym->attr.cray_pointee)
+ {
+ sym->ts.type = current_ts.type;
+ sym->ts.kind = current_ts.kind;
+ sym->ts.cl = cl;
+ sym->ts.derived = current_ts.derived;
+ m = MATCH_YES;
+
+ /* Check to see if we have an array specification. */
+ if (cp_as != NULL)
+ {
+ if (sym->as != NULL)
+ {
+ gfc_error ("Duplicate array spec for Cray pointee at %C.");
+ gfc_free_array_spec (cp_as);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else
+ {
+ if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
+ gfc_internal_error ("Couldn't set pointee array spec.");
+
+ /* Fix the array spec. */
+ m = gfc_mod_pointee_as (sym->as);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+ }
+ goto cleanup;
+ }
+ else
+ {
+ gfc_free_array_spec (cp_as);
+ }
+ }
+
+
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
- optional intialization expression for this symbol, e.g. this is
+ optional initialization expression for this symbol, e.g. this is
perfectly legal:
integer, parameter :: i = huge(i)
goto cleanup;
}
+ /* We allow old-style initializations of the form
+ integer i /2/, j(4) /3*3, 1/
+ (if no colon has been seen). These are different from data
+ statements in that initializers are only allowed to apply to the
+ variable immediately preceding, i.e.
+ integer i, j /1, 2/
+ is not allowed. Therefore we have to do some work manually, that
+ could otherwise be left to the matchers for DATA statements. */
+
+ if (!colon_seen && gfc_match (" /") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
+ "initialization at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ return match_old_style_init (name);
+ }
+
/* The double colon must be present in order to have initializers.
Otherwise the statement is ambiguous with an assignment statement. */
if (colon_seen)
}
}
+ /* Check if we are parsing an enumeration and if the current enumerator
+ variable has an initializer or not. If it does not have an
+ initializer, the initialization value of the previous enumerator
+ (stored in last_initializer) is incremented by 1 and is used to
+ initialize the current enumerator. */
+ if (gfc_current_state () == COMP_ENUM)
+ {
+ if (initializer == NULL)
+ 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",
+ &var_locus);
+ m = MATCH_ERROR;
+ gfc_free_enum_history ();
+ goto cleanup;
+ }
+
+ /* Store this current initializer, for the next enumerator
+ variable to be parsed. */
+ last_initializer = initializer;
+ }
+
/* Add the initializer. Note that it is fine if initializer is
NULL here, because we sometimes also need to check if a
declaration *must* have an initialization expression. */
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
- if (current_ts.type == BT_DERIVED && !initializer)
+ if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
gfc_match_old_kind_spec (gfc_typespec * ts)
{
match m;
+ int original_kind;
if (gfc_match_char ('*') != MATCH_YES)
return MATCH_NO;
- m = gfc_match_small_literal_int (&ts->kind);
+ m = gfc_match_small_literal_int (&ts->kind, NULL);
if (m != MATCH_YES)
return MATCH_ERROR;
+ original_kind = ts->kind;
+
/* Massage the kind numbers for complex types. */
- if (ts->type == BT_COMPLEX && ts->kind == 8)
- ts->kind = 4;
- if (ts->type == BT_COMPLEX && ts->kind == 16)
- ts->kind = 8;
+ 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;
+ }
+ ts->kind /= 2;
+ }
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
- gfc_error ("Old-style kind %d not supported for type %s at %C",
- ts->kind, gfc_basic_typename (ts->type));
-
+ gfc_error ("Old-style type declaration %s*%d not supported at %C",
+ gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
+ if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
+ gfc_basic_typename (ts->type), original_kind) == FAILURE)
+ return MATCH_ERROR;
+
return MATCH_YES;
}
gfc_clear_ts (ts);
+ if (gfc_match (" byte") == MATCH_YES)
+ {
+ if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
+ {
+ gfc_error ("BYTE type used at %C "
+ "is not available on the target machine");
+ return MATCH_ERROR;
+ }
+
+ ts->type = BT_INTEGER;
+ ts->kind = 1;
+ return MATCH_YES;
+ }
+
if (gfc_match (" integer") == MATCH_YES)
{
ts->type = BT_INTEGER;
if (gfc_match (" double complex") == MATCH_YES)
{
+ if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
+ "conform to the Fortran 95 standard") == FAILURE)
+ return MATCH_ERROR;
+
ts->type = BT_COMPLEX;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
ts->type = BT_DERIVED;
d = (decl_types) gfc_match_strings (decls);
if (d == DECL_NONE || d == DECL_COLON)
break;
+
+ if (gfc_current_state () == COMP_ENUM)
+ {
+ gfc_error ("Enumerator cannot have attributes %C");
+ return MATCH_ERROR;
+ }
seen[d]++;
seen_at[d] = gfc_current_locus;
}
}
+ /* If we are parsing an enumeration and have ensured that no other
+ attributes are present we can now set the parameter attribute. */
+ if (gfc_current_state () == COMP_ENUM)
+ {
+ t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
+ if (t == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
/* No double colon, so assume that we've been looking at something
else the whole time. */
if (d == DECL_NONE)
goto cleanup;
}
+ if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
+ && gfc_current_state () != COMP_MODULE)
+ {
+ if (d == DECL_PRIVATE)
+ attr = "PRIVATE";
+ else
+ attr = "PUBLIC";
+
+ gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
+ attr, &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
switch (d)
{
case DECL_ALLOCATABLE:
break;
case DECL_DIMENSION:
- t = gfc_add_dimension (¤t_attr, &seen_at[d]);
+ t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_EXTERNAL:
break;
case DECL_PARAMETER:
- t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]);
+ t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
case DECL_POINTER:
break;
case DECL_PRIVATE:
- t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]);
+ t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
+ &seen_at[d]);
break;
case DECL_PUBLIC:
- t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]);
+ t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
+ &seen_at[d]);
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_TARGET:
{
gfc_symbol *sym;
match m;
+ int elem;
m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
goto ok;
- if (gfc_find_symbol (current_ts.derived->name,
- current_ts.derived->ns->parent, 1, &sym) == 0)
- goto ok;
+ gfc_find_symbol (current_ts.derived->name,
+ current_ts.derived->ns->parent, 1, &sym);
- /* Hope that an ambiguous symbol is itself masked by a type definition. */
- if (sym != NULL && sym->attr.flavor == FL_DERIVED)
+ /* Any symbol that we find had better be a type definition
+ which has its components defined. */
+ if (sym != NULL && sym->attr.flavor == FL_DERIVED
+ && current_ts.derived->components != NULL)
goto ok;
- gfc_error ("Derived type at %C has not been previously defined");
- m = MATCH_ERROR;
- goto cleanup;
+ /* 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.");
+ current_attr.pointer = 1;
+ goto ok;
}
ok:
if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
gfc_match_char (',');
- /* Give the types/attributes to symbols that follow. */
+ /* Give the types/attributes to symbols that follow. Give the element
+ a number so that repeat character length expressions can be copied. */
+ elem = 1;
for (;;)
{
- m = variable_decl ();
+ m = variable_decl (elem++);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
if (sym != NULL && !st_flag
- && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
+ && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
|| gfc_missing_attr (&sym->attr, NULL) == FAILURE))
{
m = MATCH_ERROR;
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
- if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
- || gfc_add_result (&r->attr, NULL) == FAILURE)
+ if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
+ || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
m = gfc_match_formal_arglist (sym, 0, 0);
if (m == MATCH_NO)
- gfc_error ("Expected formal argument list in function definition at %C");
+ {
+ gfc_error ("Expected formal argument list in function "
+ "definition at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
else if (m == MATCH_ERROR)
goto cleanup;
/* Make changes to the symbol. */
m = MATCH_ERROR;
- if (gfc_add_function (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
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. */
+
+static bool
+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)))
+ global_used(s, NULL);
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->where = gfc_current_locus;
+ s->defined = 1;
+ return true;
+ }
+ return false;
+}
/* Match an ENTRY statement. */
gfc_compile_state state;
match m;
gfc_entry_list *el;
+ locus old_loc;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
state = gfc_current_state ();
- if (state != COMP_SUBROUTINE
- && state != COMP_FUNCTION)
+ if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
- gfc_error ("ENTRY statement at %C cannot appear within %s",
- gfc_state_name (gfc_current_state ()));
+ switch (state)
+ {
+ case COMP_PROGRAM:
+ gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
+ break;
+ case COMP_MODULE:
+ 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");
+ break;
+ case COMP_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");
+ break;
+ case COMP_IF:
+ 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");
+ break;
+ case COMP_SELECT:
+ 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");
+ break;
+ case COMP_WHERE:
+ 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");
+ break;
+ default:
+ gfc_internal_error ("gfc_match_entry(): Bad state");
+ }
return MATCH_ERROR;
}
if (state == COMP_SUBROUTINE)
{
- /* And entry in a subroutine. */
+ /* An entry in a subroutine. */
+ if (!add_global_entry (name, 1))
+ return MATCH_ERROR;
+
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
- if (gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
}
else
{
- /* An entry in a function. */
- m = gfc_match_formal_arglist (entry, 0, 0);
+ /* 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). */
+ if (!add_global_entry (name, 0))
+ return MATCH_ERROR;
+
+ old_loc = gfc_current_locus;
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ gfc_current_locus = old_loc;
+ /* Match the empty argument list, and add the interface to
+ the symbol. */
+ m = gfc_match_formal_arglist (entry, 0, 1);
+ }
+ else
+ m = gfc_match_formal_arglist (entry, 0, 0);
+
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_match_eos () == MATCH_YES)
{
- if (gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_function (&entry->attr, NULL) == FAILURE)
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
- entry->result = proc->result;
-
+ entry->result = entry;
}
else
{
if (m != MATCH_YES)
return MATCH_ERROR;
- if (gfc_add_result (&result->attr, NULL) == FAILURE
- || gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_function (&entry->attr, NULL) == FAILURE)
+ 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)
return MATCH_ERROR;
+
+ entry->result = result;
}
if (proc->attr.recursive && result == NULL)
return MATCH_ERROR;
gfc_new_block = sym;
- if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
}
-/* Return nonzero if we're currenly compiling a contained procedure. */
+/* Return nonzero if we're currently compiling a contained procedure. */
static int
contained_procedure (void)
return 0;
}
+/* Set the kind of each enumerator. The kind is selected such that it is
+ interoperable with the corresponding C enumeration type, making
+ sure that -fshort-enums is honored. */
+
+static void
+set_enum_kind(void)
+{
+ enumerator_history *current_history = NULL;
+ int kind;
+ int i;
+
+ if (max_enum == NULL || enum_history == NULL)
+ return;
+
+ if (!gfc_option.fshort_enums)
+ return;
+
+ i = 0;
+ do
+ {
+ kind = gfc_integer_kinds[i++].kind;
+ }
+ while (kind < gfc_c_int_kind
+ && gfc_check_integer_range (max_enum->initializer->value.integer,
+ kind) != ARITH_OK);
+
+ current_history = enum_history;
+ while (current_history != NULL)
+ {
+ current_history->sym->ts.kind = kind;
+ current_history = current_history->next;
+ }
+}
+
/* 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. */
eos_ok = 0;
break;
+ case COMP_ENUM:
+ *st = ST_END_ENUM;
+ target = " enum";
+ eos_ok = 0;
+ last_initializer = NULL;
+ set_enum_kind ();
+ gfc_free_enum_history ();
+ break;
+
default:
gfc_error ("Unexpected END statement at %C");
goto cleanup;
if (!eos_ok)
{
/* We would have required END [something] */
- gfc_error ("%s statement expected at %C",
- gfc_ascii_statement (*st));
+ gfc_error ("%s statement expected at %L",
+ gfc_ascii_statement (*st), &old_loc);
goto cleanup;
}
m = MATCH_ERROR;
goto cleanup;
}
+
+ if (sym->attr.cray_pointee && sym->as != NULL)
+ {
+ /* Fix the array spec. */
+ m = gfc_mod_pointee_as (sym->as);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+
+ if (gfc_add_attribute (&sym->attr, &var_locus, current_attr.intent) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
if ((current_attr.external || current_attr.intrinsic)
&& sym->attr.flavor != FL_PROCEDURE
- && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
+/* This routine matches Cray Pointer declarations of the form:
+ pointer ( <pointer>, <pointee> )
+ or
+ pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
+ The pointer, if already declared, should be an integer. Otherwise, we
+ set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
+ be either a scalar, or an array declaration. No space is allocated for
+ the pointee. For the statement
+ pointer (ipt, ar(10))
+ any subsequent uses of ar will be translated (in C-notation) as
+ ar(i) => ((<type> *) ipt)(i)
+ After gimplification, pointee variable will disappear in the code. */
+
+static match
+cray_pointer_decl (void)
+{
+ match m;
+ gfc_array_spec *as;
+ gfc_symbol *cptr; /* Pointer symbol. */
+ gfc_symbol *cpte; /* Pointee symbol. */
+ locus var_locus;
+ bool done = false;
+
+ while (!done)
+ {
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match pointer. */
+ var_locus = gfc_current_locus;
+ gfc_clear_attr (¤t_attr);
+ gfc_add_cray_pointer (¤t_attr, &var_locus);
+ current_ts.type = BT_INTEGER;
+ current_ts.kind = gfc_index_integer_kind;
+
+ m = gfc_match_symbol (&cptr, 0);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected variable name at %C");
+ return m;
+ }
+
+ if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_set_sym_referenced (cptr);
+
+ if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
+ {
+ cptr->ts.type = BT_INTEGER;
+ cptr->ts.kind = gfc_index_integer_kind;
+ }
+ else if (cptr->ts.type != BT_INTEGER)
+ {
+ gfc_error ("Cray pointer at %C must be an integer.");
+ return MATCH_ERROR;
+ }
+ 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);
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Expected \",\" at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match Pointee. */
+ var_locus = gfc_current_locus;
+ gfc_clear_attr (¤t_attr);
+ gfc_add_cray_pointee (¤t_attr, &var_locus);
+ current_ts.type = BT_UNKNOWN;
+ current_ts.kind = 0;
+
+ m = gfc_match_symbol (&cpte, 0);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected variable name at %C");
+ return m;
+ }
+
+ /* Check for an optional array spec. */
+ m = gfc_match_array_spec (&as);
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_array_spec (as);
+ return m;
+ }
+ else if (m == MATCH_NO)
+ {
+ gfc_free_array_spec (as);
+ as = NULL;
+ }
+
+ if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_set_sym_referenced (cpte);
+
+ if (cpte->as == NULL)
+ {
+ if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
+ gfc_internal_error ("Couldn't set Cray pointee array spec.");
+ }
+ else if (as != NULL)
+ {
+ gfc_error ("Duplicate array spec for Cray pointee at %C.");
+ gfc_free_array_spec (as);
+ return MATCH_ERROR;
+ }
+
+ as = NULL;
+
+ if (cpte->as != NULL)
+ {
+ /* Fix array spec. */
+ m = gfc_mod_pointee_as (cpte->as);
+ if (m == MATCH_ERROR)
+ return m;
+ }
+
+ /* Point the Pointee at the Pointer. */
+ cpte->cp_pointer = cptr;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Expected \")\" at %C");
+ return MATCH_ERROR;
+ }
+ m = gfc_match_char (',');
+ if (m != MATCH_YES)
+ done = true; /* Stop searching for more declarations. */
+
+ }
+
+ if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
+ || gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Expected \",\" or end of statement at %C");
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+}
+
+
match
gfc_match_external (void)
{
gfc_clear_attr (¤t_attr);
- gfc_add_external (¤t_attr, NULL);
+ current_attr.external = 1;
return attr_decl ();
}
return MATCH_ERROR;
gfc_clear_attr (¤t_attr);
- gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */
+ current_attr.intent = intent;
return attr_decl ();
}
{
gfc_clear_attr (¤t_attr);
- gfc_add_intrinsic (¤t_attr, NULL);
+ current_attr.intrinsic = 1;
return attr_decl ();
}
{
gfc_clear_attr (¤t_attr);
- gfc_add_optional (¤t_attr, NULL);
+ current_attr.optional = 1;
return attr_decl ();
}
match
gfc_match_pointer (void)
{
-
- gfc_clear_attr (¤t_attr);
- gfc_add_pointer (¤t_attr, NULL);
-
- return attr_decl ();
+ gfc_gobble_whitespace ();
+ if (gfc_peek_char () == '(')
+ {
+ if (!gfc_option.flag_cray_pointer)
+ {
+ gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
+ " flag.");
+ return MATCH_ERROR;
+ }
+ return cray_pointer_decl ();
+ }
+ else
+ {
+ gfc_clear_attr (¤t_attr);
+ current_attr.pointer = 1;
+
+ return attr_decl ();
+ }
}
{
gfc_clear_attr (¤t_attr);
- gfc_add_allocatable (¤t_attr, NULL);
+ current_attr.allocatable = 1;
return attr_decl ();
}
{
gfc_clear_attr (¤t_attr);
- gfc_add_dimension (¤t_attr, NULL);
+ current_attr.dimension = 1;
return attr_decl ();
}
{
gfc_clear_attr (¤t_attr);
- gfc_add_target (¤t_attr, NULL);
+ current_attr.target = 1;
return attr_decl ();
}
if (gfc_add_access (&sym->attr,
(st ==
ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
- NULL) == FAILURE)
+ sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;
}
if (gfc_check_assign_symbol (sym, init) == FAILURE
- || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
+ || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.cl != NULL
+ && sym->ts.cl->length != NULL
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT
+ && init->expr_type == EXPR_CONSTANT
+ && init->ts.type == BT_CHARACTER
+ && init->ts.kind == 1)
+ gfc_set_constant_character_len (
+ mpz_get_si (sym->ts.cl->length->value.integer), init);
+
sym->value = init;
return MATCH_YES;
{
if (gfc_current_ns->seen_save)
{
- gfc_error ("Blanket SAVE statement at %C follows previous "
- "SAVE statement");
-
- return MATCH_ERROR;
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Blanket SAVE statement at %C follows previous "
+ "SAVE statement")
+ == FAILURE)
+ return MATCH_ERROR;
}
gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
if (gfc_current_ns->save_all)
{
- gfc_error ("SAVE statement at %C follows blanket SAVE statement");
- return MATCH_ERROR;
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "SAVE statement at %C follows blanket SAVE statement")
+ == FAILURE)
+ return MATCH_ERROR;
}
gfc_match (" ::");
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
+ if (gfc_add_save (&sym->attr, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
/* Match a module procedure statement. Note that we have to modify
symbols in the parent's namespace because the current one was there
- to receive symbols that are in a interface's formal argument list. */
+ to receive symbols that are in an interface's formal argument list. */
match
gfc_match_modproc (void)
return MATCH_ERROR;
if (sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_interface (sym) == FAILURE)
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
+ if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
+ if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
derived type that is a pointer. The first part of the AND clause
- is true if a the symbol is not the return value of a function. */
+ is true if a the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->components != NULL)
}
if (attr.access != ACCESS_UNKNOWN
- && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
+ && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
return MATCH_YES;
}
+
+
+/* Cray Pointees can be declared as:
+ pointer (ipt, a (n,m,...,*))
+ By default, this is treated as an AS_ASSUMED_SIZE array. We'll
+ cheat and set a constant bound of 1 for the last dimension, if this
+ is the case. Since there is no bounds-checking for Cray Pointees,
+ this will be okay. */
+
+try
+gfc_mod_pointee_as (gfc_array_spec *as)
+{
+ as->cray_pointee = true; /* This will be useful to know later. */
+ if (as->type == AS_ASSUMED_SIZE)
+ {
+ as->type = AS_EXPLICIT;
+ as->upper[as->rank - 1] = gfc_int_expr (1);
+ as->cp_was_assumed = true;
+ }
+ else if (as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Cray Pointee at %C cannot be assumed shape array");
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+}
+
+
+/* Match the enum definition statement, here we are trying to match
+ the first line of enum definition statement.
+ Returns MATCH_YES if match is found. */
+
+match
+gfc_match_enum (void)
+{
+ match m;
+
+ m = gfc_match_eos ();
+ if (m != MATCH_YES)
+ return m;
+
+ if (gfc_notify_std (GFC_STD_F2003,
+ "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
+/* Match the enumerator definition statement. */
+
+match
+gfc_match_enumerator_def (void)
+{
+ match m;
+ int elem;
+
+ gfc_clear_ts (¤t_ts);
+
+ m = gfc_match (" enumerator");
+ if (m != MATCH_YES)
+ return m;
+
+ if (gfc_current_state () != COMP_ENUM)
+ {
+ gfc_error ("ENUM definition statement expected before %C");
+ gfc_free_enum_history ();
+ return MATCH_ERROR;
+ }
+
+ (¤t_ts)->type = BT_INTEGER;
+ (¤t_ts)->kind = gfc_c_int_kind;
+
+ m = match_attr_spec ();
+ if (m == MATCH_ERROR)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ elem = 1;
+ for (;;)
+ {
+ m = variable_decl (elem++);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ break;
+
+ if (gfc_match_eos () == MATCH_YES)
+ goto cleanup;
+ if (gfc_match_char (',') != MATCH_YES)
+ break;
+ }
+
+ if (gfc_current_state () == COMP_ENUM)
+ {
+ gfc_free_enum_history ();
+ gfc_error ("Syntax error in ENUMERATOR definition at %C");
+ m = MATCH_ERROR;
+ }
+
+cleanup:
+ gfc_free_array_spec (current_as);
+ current_as = NULL;
+ return m;
+
+}
+
OSDN Git Service
