OSDN Git Service

fortran/
authortobi <tobi@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 29 Aug 2004 16:58:39 +0000 (16:58 +0000)
committertobi <tobi@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 29 Aug 2004 16:58:39 +0000 (16:58 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@86729 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/gfortran.texi
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/symbol.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/oldstyle_1.f90 [new file with mode: 0644]

index fd405fe..d1f3edb 100644 (file)
@@ -1,3 +1,19 @@
+2004-08-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       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.
+
 2004-08-29  Steven G. Kargl  <kargls@comcast.net>
        Paul Brook  <paul@codesourcery.com>
 
index 4ab5839..a3aa28b 100644 (file)
@@ -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)
index f981185..ab83064 100644 (file)
@@ -1983,3 +1983,30 @@ gfc_default_initializer (gfc_typespec *ts)
     }
   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 89c182d..3c5e69a 100644 (file)
@@ -789,6 +789,8 @@ typedef struct gfc_namespace
   gfc_access default_access, operator_access[GFC_INTRINSIC_OPS];
 
   gfc_st_label *st_labels;
+  /* This list holds information about all the data initializers in
+     this namespace.  */
   struct gfc_data *data;
 
   gfc_charlen *cl_list;
@@ -1688,6 +1690,8 @@ try gfc_check_pointer_assign (gfc_expr *, 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 c1a0fe1..8f6c0e6 100644 (file)
@@ -128,9 +128,10 @@ not accurately reflect the status of the most recent @command{gfortran}.
 * 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 unformatted read.
 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 cd1dbe8..f9628e8 100644 (file)
@@ -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 032a6a3..1d46e85 100644 (file)
@@ -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 char *, int);
 
 /* 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 b709721..25419cc 100644 (file)
@@ -1763,13 +1763,13 @@ ambiguous_symbol (const char *name, gfc_symtree * st)
 }
 
 
-/* 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_namespace * ns, int parent_flag,
 }
 
 
+/* Same, but returns the symbol instead.  */
+
 int
 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
                 gfc_symbol ** result)
index 84c03ab..ada3528 100644 (file)
@@ -1,3 +1,8 @@
+2004-08-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/13910
+       * gfortran.dg/oldstyle_1.f90: New test.
+
 2004-08-29  Steven G. Kargl  <kargls@comcast.net>
        Paul Brook  <paul@codesourcery.com>
 
diff --git a/gcc/testsuite/gfortran.dg/oldstyle_1.f90 b/gcc/testsuite/gfortran.dg/oldstyle_1.f90
new file mode 100644 (file)
index 0000000..e26c467
--- /dev/null
@@ -0,0 +1,9 @@
+      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