mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-10 01:40:47 +08:00
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
This commit is contained in:
Tobias Schlüter
Tobias Schlüter
parent
048c989961
commit
294fbfc89f
gcc
fortran
testsuite
@ -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>
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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. */
|
||||
|
||||
@ -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 *);
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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>
|
||||
|
||||
|
||||
9
gcc/testsuite/gfortran.dg/oldstyle_1.f90
Normal file
9
gcc/testsuite/gfortran.dg/oldstyle_1.f90
Normal file
@ -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
|
||||
Loading…
x
Reference in New Issue
Block a user