[gfortran] Fix PR13910: old-style variable initialization with gfortran

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Paul Brook wrote:
> Section 5 of the Intel Fortran Language Reference contains a fairly good 
> description.
> http://www.intel.com/software/products/compilers/docs/for_lang.htm

:-) I only looked through their overview on language extensions (Appendix F),
and didn't see it mentioned there, so I assumed it wasn't documented. Thanks
for the pointer. It looks like I implemented what that text says, so here's my
patch.

The biggest part is moving the stuff for matching DATA statements from match.c
to decl.c. This seemed logical enough, and I use top_val_list() in the new
function match_oldstyle_init(). This function is called from variable_decl()
if we encounter a slash under the right conditions, and adds the encountered
initializers to the namespace's list of datas, and that's how it works.

Built and tested, ChangeLog below, patch and testcase attached.

- Tobi

2004-08-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

	* 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.

Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/decl.c,v
retrieving revision 1.21
diff -u -p -r1.21 decl.c
--- decl.c	27 Aug 2004 14:49:34 -0000	1.21
+++ decl.c	29 Aug 2004 14:49:07 -0000
@@ -48,6 +48,401 @@ 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)
+    return m;
+
+  /* Chain in namespace list of DATA initializers.  */
+  newdata->next = gfc_current_ns->data;
+  gfc_current_ns->data = newdata;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Initialization at %C is not allowed in a PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  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 +919,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)
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.15
diff -u -p -r1.15 expr.c
--- expr.c	27 Aug 2004 14:49:34 -0000	1.15
+++ expr.c	29 Aug 2004 14:49:10 -0000
@@ -1983,3 +1983,30 @@ gfc_default_initializer (gfc_typespec *t
     }
   return init;
 }
+
+
+/* Given a symbol, create an expression node with that symbol as a
+   variable. If the symbol is array valued, setup a reference of the
+   whole array.  */
+
+gfc_expr *
+gfc_get_variable_expr (gfc_symtree * var)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_VARIABLE;
+  e->symtree = var;
+  e->ts = var->n.sym->ts;
+
+  if (var->n.sym->as != NULL)
+    {
+      e->rank = var->n.sym->as->rank;
+      e->ref = gfc_get_ref ();
+      e->ref->type = REF_ARRAY;
+      e->ref->u.ar.type = AR_FULL;
+    }
+
+  return e;
+}
+
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.30
diff -u -p -r1.30 gfortran.h
--- gfortran.h	28 Aug 2004 23:43:38 -0000	1.30
+++ gfortran.h	29 Aug 2004 14:49:10 -0000
@@ -1679,6 +1679,8 @@ try gfc_check_pointer_assign (gfc_expr *
 try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 
 gfc_expr *gfc_default_initializer (gfc_typespec *);
+gfc_expr *gfc_get_variable_expr (gfc_symtree *);
+
 
 /* st.c */
 extern gfc_code new_st;
Index: gfortran.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.texi,v
retrieving revision 1.6
diff -u -p -r1.6 gfortran.texi
--- gfortran.texi	5 Jun 2004 14:41:42 -0000	1.6
+++ gfortran.texi	29 Aug 2004 14:49:10 -0000
@@ -128,9 +128,10 @@ not accurately reflect the status of the
 * GFORTRAN and GCC::	    You can compile Fortran, C, or other programs.
 * GFORTRAN and G77::     Why we choose to start from scratch.
 * Invoking GFORTRAN::    Command options supported by @command{gfortran}.
-* Project Status::  Status of GFORTRAN, Roadmap, proposed extensions.
+* Project Status::  Status of @command{gfortran}, Roadmap, proposed extensions.
 * Contributing::    Helping you can help.
-* Standards::	    Standards supported by GFORTRAN.
+* Standards::	    Standards supported by @command{gfortran}
+* Extensions::      Laguage extensions implemented by @command{gfortran}
 * Index::	    Index of this documentation.
 @end menu
 
@@ -608,7 +609,71 @@ Variable for swapping endianness during 
 Variable for swapping Endianness during unformatted write.
 @end itemize
 
+@c ---------------------------------------------------------------------
+@c Extensions
+@c ---------------------------------------------------------------------
+
+@c Maybe this chapter should be merged with the 'Standards' section,
+@c whenever that is written :-)
+
+@node Extensions
+@chapter Extensions
+@cindex Extension
+
+@command{gfortran} implements a number of extensions over standard
+Fortran. This chapter contains information on their syntax and
+meaning.
+
+@menu
+* Old-style kind specifications::
+* Old-style variable initialization::
+@end menu
 
+@node Old-style kind specifications
+@section Old-style kind specifications
+@cindex Kind specifications
+
+@command{gfortran} allows old-style kind specifications in
+declarations. These look like:
+@smallexample
+      TYPESPEC*k x,y,z
+@end smallexample
+where @code{TYPESPEC} is a basic type, and where @code{k} is a valid kind
+number for that type. The statement then declares @code{x}, @code{y}
+and @code{z} to be of type @code{TYPESPEC} with kind @code{k}. In
+other words, it is equivalent to the standard conforming declaration
+@smallexample
+      TYPESPEC(k) x,y,z
+@end smallexample
+
+@node Old-style variable initialization
+@section Old-style variable initialization
+@cindex Initialization
+
+@command{gfortran} allows old-style initialization of variables of the
+form:
+@smallexample
+      INTEGER*4 i/1/,j/2/
+      REAL*8 x(2,2) /3*0.,1./
+@end smallexample
+These are only allowed in declarations without double colons
+(@code{::}), as these were introduced in Fortran 90 which also
+introduced a new syntax for variable initializations. The syntax for
+the individual initializers is as for the @code{DATA} statement, but
+unlike in a @code{DATA} statement, an initializer only applies to the
+variable immediately preceding. In other words, something like
+@code{INTEGER I,J/2,3/} is not valid.
+
+Examples of standard conforming code equivalent to the above example, are:
+@smallexample
+! Fortran 90
+      INTEGER(4) :: i = 1, j = 2
+      REAL(8) :: x(2,2) = RESHAPE((/0.,0.,0.,1./),SHAPE(x))
+! Fortran 77
+      INTEGER  i, j
+      DOUBLE PRECISION x(2,2)
+      DATA i,j,x /1,2,3*0.,1./
+@end smallexample
 
 @c ---------------------------------------------------------------------
 @c Contributing
Index: match.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.22
diff -u -p -r1.22 match.c
--- match.c	27 Aug 2004 14:49:34 -0000	1.22
+++ match.c	29 Aug 2004 14:49:12 -0000
@@ -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.  */
Index: match.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.h,v
retrieving revision 1.9
diff -u -p -r1.9 match.h
--- match.h	10 Jul 2004 22:37:15 -0000	1.9
+++ match.h	29 Aug 2004 14:49:12 -0000
@@ -80,7 +80,6 @@ match gfc_match_namelist (void);
 match gfc_match_module (void);
 match gfc_match_equivalence (void);
 match gfc_match_st_function (void);
-match gfc_match_data (void);
 match gfc_match_case (void);
 match gfc_match_select (void);
 match gfc_match_where (gfc_statement *);
@@ -93,6 +92,7 @@ gfc_common_head *gfc_get_common (const c
 
 /* decl.c */
 
+match gfc_match_data (void);
 match gfc_match_null (gfc_expr **);
 match gfc_match_kind_spec (gfc_typespec *);
 match gfc_match_old_kind_spec (gfc_typespec *);
Index: symbol.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.14
diff -u -p -r1.14 symbol.c
--- symbol.c	27 Aug 2004 14:49:34 -0000	1.14
+++ symbol.c	29 Aug 2004 14:49:12 -0000
@@ -1763,13 +1763,13 @@ ambiguous_symbol (const char *name, gfc_
 }
 
 
-/* Search for a symbol starting in the current namespace, resorting to
+/* Search for a symtree starting in the current namespace, resorting to
    any parent namespaces if requested by a nonzero parent_flag.
-   Returns nonzero if the symbol is ambiguous.  */
+   Returns nonzero if the name is ambiguous.  */
 
 int
 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
-		 gfc_symtree ** result)
+		   gfc_symtree ** result)
 {
   gfc_symtree *st;
 
@@ -1803,6 +1803,8 @@ gfc_find_sym_tree (const char *name, gfc
 }
 
 
+/* Same, but returns the symbol instead.  */
+
 int
 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
 		 gfc_symbol ** result)

      integer i, j /1/, g/2/, h ! { dg-warning "" "" }
      integer k, l(3) /2*2,1/   ! { dg-warning "" "" }
      real pi /3.1416/, e       ! { dg-warning "" "" }

      if (j /= 1) call abort ()
      if (g /= 2) call abort ()
      if (any(l /= (/2,2,1/))) call abort ()
      if (pi /= 3.1416) call abort ()
      end