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.c417
1 files changed, 417 insertions, 0 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 4ab5839..a3aa28b 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -48,6 +48,405 @@ static int colon_seen;
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->value != NULL)
+ {
+ gfc_error ("Variable '%s' at %C already has an initialization",
+ sym->name);
+ return MATCH_ERROR;
+ }
+
+#if 0 // TODO: Find out where to move this message
+ if (sym->attr.in_common)
+ /* See if sym is in the blank common block. */
+ for (t = &sym->ns->blank_common; t; t = t->common_next)
+ if (sym == t->head)
+ {
+ gfc_error ("DATA statement at %C may not initialize variable "
+ "'%s' from blank COMMON", sym->name);
+ return MATCH_ERROR;
+ }
+#endif
+
+ if (gfc_add_data (&sym->attr, &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 stement and are therefore issuing an error
+ if we encounter something unexpected, if not, we're trying to match
+ an old-style intialization 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. */
@@ -524,6 +923,24 @@ variable_decl (void)
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 let 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)
generated by cgit v1.1 at 2025-05-25 16:14:54 +0000