re PR fortran/13910 (Cannot initialize variables with declation as allowed by g77)

fortran/
PR fortran/13910
* decl.c (free_variable, free_value, gfc_free_data, var_list,
var_element, top_var_list, match_data_constant, top_val_list,
gfc_match_data): Move here from match.c.
(match_old_style_init): New function.
(variable_decl): Match old-style initialization.
* expr.c (gfc_get_variable_expr): New function.
* gfortran.h (gfc_get_variable_expr): Add prototype.
* gfortran.texi: Start documentation for supported extensions.
* match.c: Remove the functions moved to decl.c.
* match.h (gfc_match_data): Move prototype to under decl.c.
* symbol.c (gfc_find_sym_tree, gfc_find_symbol): Add/correct
comments.

testsuite/
PR fortran/13910
* gfortran.dg/oldstyle_1.f90: New test.

From-SVN: r86729

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)