aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/match.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/match.c')
-rw-r--r--gcc/fortran/match.c355
1 files changed, 0 insertions, 355 deletions
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index cd1dbe8..f9628e8 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2614,361 +2614,6 @@ undo_error:
}
-/********************* 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;
-}
-
-
-/* Match a DATA statement. */
-
-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;
-}
-
-
/***************** SELECT CASE subroutines ******************/
/* Free a single case structure. */
generated by cgit v1.1 at 2025-05-31 14:53:51 +0000