#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
static int old_char_selector;
static gfc_typespec current_ts;
static symbol_attribute current_attr;
static gfc_array_spec *current_as;
static int colon_seen;
gfc_symbol *gfc_new_block;
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);
}
}
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);
}
}
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 *);
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;
}
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)
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, sym->name, &new->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
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;
}
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;
}
static match
match_old_style_init (const char *name)
{
match m;
gfc_symtree *st;
gfc_data *newdata;
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);
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;
}
newdata->next = gfc_current_ns->data;
gfc_current_ns->data = newdata;
return m;
}
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 (',');
}
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;
}
static sym_intent
match_intent_spec (void)
{
if (gfc_match (" ( in out )") == MATCH_YES)
return INTENT_INOUT;
if (gfc_match (" ( in )") == MATCH_YES)
return INTENT_IN;
if (gfc_match (" ( out )") == MATCH_YES)
return INTENT_OUT;
gfc_error ("Bad INTENT specification at %C");
return INTENT_UNKNOWN;
}
static match
char_len_param_value (gfc_expr ** expr)
{
if (gfc_match_char ('*') == MATCH_YES)
{
*expr = NULL;
return MATCH_YES;
}
return gfc_match_expr (expr);
}
static match
match_char_length (gfc_expr ** expr)
{
int length;
match m;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
m = gfc_match_small_literal_int (&length);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_YES)
{
*expr = gfc_int_expr (length);
return m;
}
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
m = char_len_param_value (expr);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
goto syntax;
if (gfc_match_char (')') == MATCH_NO)
{
gfc_free_expr (*expr);
*expr = NULL;
goto syntax;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in character length specification at %C");
return MATCH_ERROR;
}
static int
find_special (const char *name, gfc_symbol ** result)
{
gfc_state_data *s;
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
goto normal;
s = gfc_state_stack->previous;
if (s == NULL)
goto normal;
if (s->state != COMP_INTERFACE)
goto normal;
if (s->sym == NULL)
goto normal;
if (strcmp (name, s->sym->name) == 0)
{
*result = s->sym;
return 0;
}
normal:
return gfc_get_symbol (name, NULL, result);
}
static int
get_proc_name (const char *name, gfc_symbol ** result)
{
gfc_symtree *st;
gfc_symbol *sym;
int rc;
if (gfc_current_ns->parent == NULL)
return gfc_get_symbol (name, NULL, result);
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
if (*result == NULL)
return rc;
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
sym = *result;
st->n.sym = sym;
sym->refs++;
if (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
rc = 2;
return rc;
}
static try
build_sym (const char *name, gfc_charlen * cl,
gfc_array_spec ** as, locus * var_locus)
{
symbol_attribute attr;
gfc_symbol *sym;
if (find_special (name, &sym))
return FAILURE;
if (current_ts.type != BT_UNKNOWN
&&(sym->attr.implicit_type == 0
|| !gfc_compare_types (&sym->ts, ¤t_ts))
&& gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
sym->ts.cl = cl;
if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
return FAILURE;
*as = NULL;
attr = current_attr;
attr.dimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
return SUCCESS;
}
void
gfc_set_constant_character_len (int len, gfc_expr * expr)
{
char * s;
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
slen = expr->value.character.length;
if (len != slen)
{
s = gfc_getmem (len);
memcpy (s, expr->value.character.string, MIN (len, slen));
if (len > slen)
memset (&s[slen], ' ', len - slen);
gfc_free (expr->value.character.string);
expr->value.character.string = s;
expr->value.character.length = len;
}
}
static try
add_init_expr_to_sym (const char *name, gfc_expr ** initp,
locus * var_locus)
{
symbol_attribute attr;
gfc_symbol *sym;
gfc_expr *init;
init = *initp;
if (find_special (name, &sym))
return FAILURE;
attr = sym->attr;
if (attr.flavor == FL_PARAMETER
&& sym->value != NULL
&& *initp != NULL)
{
gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
sym->name);
return FAILURE;
}
if (attr.in_common
&& !attr.data
&& *initp != NULL)
{
gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
sym->name);
return FAILURE;
}
if (init == NULL)
{
if (attr.flavor == FL_PARAMETER)
{
gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
return FAILURE;
}
}
else
{
if (sym->attr.data)
{
gfc_error
("Variable '%s' at %C with an initializer already appears "
"in a DATA statement", sym->name);
return FAILURE;
}
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
{
if (sym->ts.cl->length == NULL)
{
if (init->expr_type == EXPR_CONSTANT)
sym->ts.cl->length =
gfc_int_expr (init->value.character.length);
else if (init->expr_type == EXPR_ARRAY)
sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
}
else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.cl->length->value.integer);
gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init);
else if (init->expr_type == EXPR_ARRAY)
{
gfc_free_expr (init->ts.cl->length);
init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
for (p = init->value.constructor; p; p = p->next)
gfc_set_constant_character_len (len, p->expr);
}
}
}
if (sym->attr.dimension && init->rank == 0)
init->rank = sym->as->rank;
sym->value = init;
*initp = NULL;
}
return SUCCESS;
}
static try
build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
gfc_array_spec ** as)
{
gfc_component *c;
if (current_ts.type == BT_DERIVED
&& current_ts.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
gfc_error ("Component at %C must have the POINTER attribute");
return FAILURE;
}
if (gfc_current_block ()->attr.pointer
&& (*as)->rank != 0)
{
if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
{
gfc_error ("Array component of structure at %C must have explicit "
"or deferred shape");
return FAILURE;
}
}
if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
return FAILURE;
c->ts = current_ts;
c->ts.cl = cl;
gfc_set_component_attr (c, ¤t_attr);
c->initializer = *init;
*init = NULL;
c->as = *as;
if (c->as != NULL)
c->dimension = 1;
*as = NULL;
if (!c->dimension)
return SUCCESS;
if (c->pointer)
{
if (c->as->type != AS_DEFERRED)
{
gfc_error ("Pointer array component of structure at %C "
"must have a deferred shape");
return FAILURE;
}
}
else
{
if (c->as->type != AS_EXPLICIT)
{
gfc_error
("Array component of structure at %C must have an explicit "
"shape");
return FAILURE;
}
}
return SUCCESS;
}
match
gfc_match_null (gfc_expr ** result)
{
gfc_symbol *sym;
gfc_expr *e;
match m;
m = gfc_match (" null ( )");
if (m != MATCH_YES)
return m;
if (gfc_get_symbol ("null", NULL, &sym))
{
gfc_error ("NULL() initialization at %C is ambiguous");
return MATCH_ERROR;
}
gfc_intrinsic_symbol (sym);
if (sym->attr.proc != PROC_INTRINSIC
&& (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
sym->name, NULL) == FAILURE
|| gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
e = gfc_get_expr ();
e->where = gfc_current_locus;
e->expr_type = EXPR_NULL;
e->ts.type = BT_UNKNOWN;
*result = e;
return MATCH_YES;
}
static match
variable_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
gfc_charlen *cl;
locus var_locus;
match m;
try t;
initializer = NULL;
as = NULL;
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
var_locus = gfc_current_locus;
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
char_len = NULL;
cl = NULL;
if (current_ts.type == BT_CHARACTER)
{
switch (match_char_length (&char_len))
{
case MATCH_YES:
cl = gfc_get_charlen ();
cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = cl;
cl->length = char_len;
break;
case MATCH_NO:
cl = current_ts.cl;
break;
case MATCH_ERROR:
goto cleanup;
}
}
if (gfc_current_state () != COMP_DERIVED
&& build_sym (name, cl, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_current_state () == COMP_FUNCTION
&& gfc_current_block () != NULL
&& gfc_current_block ()->result != NULL
&& gfc_current_block ()->result != gfc_current_block ()
&& strcmp (gfc_current_block ()->name, name) == 0)
{
gfc_error ("Function name '%s' not allowed at %C", name);
m = MATCH_ERROR;
goto cleanup;
}
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);
}
if (colon_seen)
{
if (gfc_match (" =>") == MATCH_YES)
{
if (!current_attr.pointer)
{
gfc_error ("Initialization at %C isn't for a pointer variable");
m = MATCH_ERROR;
goto cleanup;
}
m = gfc_match_null (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Pointer initialization requires a NULL at %C");
m = MATCH_ERROR;
}
if (gfc_pure (NULL))
{
gfc_error
("Initialization of pointer at %C is not allowed in a "
"PURE procedure");
m = MATCH_ERROR;
}
if (m != MATCH_YES)
goto cleanup;
initializer->ts = current_ts;
}
else if (gfc_match_char ('=') == MATCH_YES)
{
if (current_attr.pointer)
{
gfc_error
("Pointer initialization at %C requires '=>', not '='");
m = MATCH_ERROR;
goto cleanup;
}
m = gfc_match_init_expr (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Expected an initialization expression at %C");
m = MATCH_ERROR;
}
if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
{
gfc_error
("Initialization of variable at %C is not allowed in a "
"PURE procedure");
m = MATCH_ERROR;
}
if (m != MATCH_YES)
goto cleanup;
}
}
if (gfc_current_state () != COMP_DERIVED)
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
if (current_ts.type == BT_DERIVED && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
cleanup:
gfc_free_expr (initializer);
gfc_free_array_spec (as);
return m;
}
match
gfc_match_old_kind_spec (gfc_typespec * ts)
{
match m;
if (gfc_match_char ('*') != MATCH_YES)
return MATCH_NO;
m = gfc_match_small_literal_int (&ts->kind);
if (m != MATCH_YES)
return MATCH_ERROR;
if (ts->type == BT_COMPLEX && ts->kind == 8)
ts->kind = 4;
if (ts->type == BT_COMPLEX && ts->kind == 16)
ts->kind = 8;
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
gfc_error ("Old-style kind %d not supported for type %s at %C",
ts->kind, gfc_basic_typename (ts->type));
return MATCH_ERROR;
}
return MATCH_YES;
}
match
gfc_match_kind_spec (gfc_typespec * ts)
{
locus where;
gfc_expr *e;
match m, n;
const char *msg;
m = MATCH_NO;
e = NULL;
where = gfc_current_locus;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
if (gfc_match (" kind = ") == MATCH_YES)
m = MATCH_ERROR;
n = gfc_match_init_expr (&e);
if (n == MATCH_NO)
gfc_error ("Expected initialization expression at %C");
if (n != MATCH_YES)
return MATCH_ERROR;
if (e->rank != 0)
{
gfc_error ("Expected scalar initialization expression at %C");
m = MATCH_ERROR;
goto no_match;
}
msg = gfc_extract_int (e, &ts->kind);
if (msg != NULL)
{
gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
gfc_free_expr (e);
e = NULL;
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
gfc_basic_typename (ts->type));
m = MATCH_ERROR;
goto no_match;
}
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right paren at %C");
goto no_match;
}
return MATCH_YES;
no_match:
gfc_free_expr (e);
gfc_current_locus = where;
return m;
}
static match
match_char_spec (gfc_typespec * ts)
{
int i, kind, seen_length;
gfc_charlen *cl;
gfc_expr *len;
match m;
kind = gfc_default_character_kind;
len = NULL;
seen_length = 0;
old_char_selector = 0;
m = match_char_length (&len);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
old_char_selector = 1;
seen_length = 1;
goto done;
}
m = gfc_match_char ('(');
if (m != MATCH_YES)
{
m = MATCH_YES;
goto done;
}
if (gfc_match (" kind =") == MATCH_YES)
{
m = gfc_match_small_int (&kind);
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
goto syntax;
if (gfc_match (" , len =") == MATCH_NO)
goto rparen;
m = char_len_param_value (&len);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto done;
seen_length = 1;
goto rparen;
}
if (gfc_match (" len =") == MATCH_YES)
{
m = char_len_param_value (&len);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto done;
seen_length = 1;
if (gfc_match_char (')') == MATCH_YES)
goto done;
if (gfc_match (" , kind =") != MATCH_YES)
goto syntax;
gfc_match_small_int (&kind);
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
{
gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
return MATCH_YES;
}
goto rparen;
}
m = char_len_param_value (&len);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto done;
seen_length = 1;
m = gfc_match_char (')');
if (m == MATCH_YES)
goto done;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
gfc_match (" kind =");
m = gfc_match_small_int (&kind);
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
goto syntax;
rparen:
m = gfc_match_char (')');
if (m == MATCH_YES)
goto done;
syntax:
gfc_error ("Syntax error in CHARACTER declaration at %C");
m = MATCH_ERROR;
done:
if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
{
gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
m = MATCH_ERROR;
}
if (m != MATCH_YES)
{
gfc_free_expr (len);
return m;
}
cl = gfc_get_charlen ();
cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = cl;
if (seen_length == 0)
cl->length = gfc_int_expr (1);
else
{
if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
cl->length = len;
else
{
gfc_free_expr (len);
cl->length = gfc_int_expr (0);
}
}
ts->cl = cl;
ts->kind = kind;
return MATCH_YES;
}
static match
match_type_spec (gfc_typespec * ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
int c;
gfc_clear_ts (ts);
if (gfc_match (" integer") == MATCH_YES)
{
ts->type = BT_INTEGER;
ts->kind = gfc_default_integer_kind;
goto get_kind;
}
if (gfc_match (" character") == MATCH_YES)
{
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
return match_char_spec (ts);
else
return MATCH_YES;
}
if (gfc_match (" real") == MATCH_YES)
{
ts->type = BT_REAL;
ts->kind = gfc_default_real_kind;
goto get_kind;
}
if (gfc_match (" double precision") == MATCH_YES)
{
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
if (gfc_match (" complex") == MATCH_YES)
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_complex_kind;
goto get_kind;
}
if (gfc_match (" double complex") == MATCH_YES)
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
if (gfc_match (" logical") == MATCH_YES)
{
ts->type = BT_LOGICAL;
ts->kind = gfc_default_logical_kind;
goto get_kind;
}
m = gfc_match (" type ( %n )", name);
if (m != MATCH_YES)
return m;
if (gfc_get_ha_symbol (name, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
ts->type = BT_DERIVED;
ts->kind = 0;
ts->derived = sym;
return MATCH_YES;
get_kind:
if (implicit_flag == 1)
return MATCH_YES;
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_char();
if (!gfc_is_whitespace(c) && c != '*' && c != '('
&& c != ':' && c != ',')
return MATCH_NO;
}
m = gfc_match_kind_spec (ts);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
if (m == MATCH_NO)
m = MATCH_YES;
return m;
}
match
gfc_match_implicit_none (void)
{
return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
}
static match
match_implicit_range (void)
{
int c, c1, c2, inner;
locus cur_loc;
cur_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (c != '(')
{
gfc_error ("Missing character range in IMPLICIT at %C");
goto bad;
}
inner = 1;
while (inner)
{
gfc_gobble_whitespace ();
c1 = gfc_next_char ();
if (!ISALPHA (c1))
goto bad;
gfc_gobble_whitespace ();
c = gfc_next_char ();
switch (c)
{
case ')':
inner = 0;
case ',':
c2 = c1;
break;
case '-':
gfc_gobble_whitespace ();
c2 = gfc_next_char ();
if (!ISALPHA (c2))
goto bad;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if ((c != ',') && (c != ')'))
goto bad;
if (c == ')')
inner = 0;
break;
default:
goto bad;
}
if (c1 > c2)
{
gfc_error ("Letters must be in alphabetic order in "
"IMPLICIT statement at %C");
goto bad;
}
if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
goto bad;
}
return MATCH_YES;
bad:
gfc_syntax_error (ST_IMPLICIT);
gfc_current_locus = cur_loc;
return MATCH_ERROR;
}
match
gfc_match_implicit (void)
{
gfc_typespec ts;
locus cur_loc;
int c;
match m;
if (gfc_match_eos () == MATCH_YES)
{
gfc_error ("Empty IMPLICIT statement at %C");
return MATCH_ERROR;
}
do
{
gfc_clear_new_implicit ();
m = match_type_spec (&ts, 1);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
goto syntax;
cur_loc = gfc_current_locus;
m = match_implicit_range ();
if (m == MATCH_YES)
{
gfc_gobble_whitespace ();
c = gfc_next_char ();
if ((c == '\n') || (c == ','))
{
if (ts.type == BT_CHARACTER && !ts.cl)
{
ts.kind = gfc_default_character_kind;
ts.cl = gfc_get_charlen ();
ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = ts.cl;
ts.cl->length = gfc_int_expr (1);
}
if (gfc_merge_new_implicit (&ts) != SUCCESS)
return MATCH_ERROR;
continue;
}
gfc_current_locus = cur_loc;
}
gfc_clear_new_implicit ();
if (ts.type == BT_CHARACTER)
m = match_char_spec (&ts);
else
{
m = gfc_match_kind_spec (&ts);
if (m == MATCH_NO)
{
m = gfc_match_old_kind_spec (&ts);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
goto syntax;
}
}
if (m == MATCH_ERROR)
goto error;
m = match_implicit_range ();
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
goto syntax;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if ((c != '\n') && (c != ','))
goto syntax;
if (gfc_merge_new_implicit (&ts) != SUCCESS)
return MATCH_ERROR;
}
while (c == ',');
return MATCH_YES;
syntax:
gfc_syntax_error (ST_IMPLICIT);
error:
return MATCH_ERROR;
}
static match
match_attr_spec (void)
{
typedef enum
{ GFC_DECL_BEGIN = 0,
DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
DECL_TARGET, DECL_COLON, DECL_NONE,
GFC_DECL_END
}
decl_types;
#define NUM_DECL GFC_DECL_END
static mstring decls[] = {
minit (", allocatable", DECL_ALLOCATABLE),
minit (", dimension", DECL_DIMENSION),
minit (", external", DECL_EXTERNAL),
minit (", intent ( in )", DECL_IN),
minit (", intent ( out )", DECL_OUT),
minit (", intent ( in out )", DECL_INOUT),
minit (", intrinsic", DECL_INTRINSIC),
minit (", optional", DECL_OPTIONAL),
minit (", parameter", DECL_PARAMETER),
minit (", pointer", DECL_POINTER),
minit (", private", DECL_PRIVATE),
minit (", public", DECL_PUBLIC),
minit (", save", DECL_SAVE),
minit (", target", DECL_TARGET),
minit ("::", DECL_COLON),
minit (NULL, DECL_NONE)
};
locus start, seen_at[NUM_DECL];
int seen[NUM_DECL];
decl_types d;
const char *attr;
match m;
try t;
gfc_clear_attr (¤t_attr);
start = gfc_current_locus;
current_as = NULL;
colon_seen = 0;
for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
seen[d] = 0;
for (;;)
{
d = (decl_types) gfc_match_strings (decls);
if (d == DECL_NONE || d == DECL_COLON)
break;
seen[d]++;
seen_at[d] = gfc_current_locus;
if (d == DECL_DIMENSION)
{
m = gfc_match_array_spec (¤t_as);
if (m == MATCH_NO)
{
gfc_error ("Missing dimension specification at %C");
m = MATCH_ERROR;
}
if (m == MATCH_ERROR)
goto cleanup;
}
}
if (d == DECL_NONE)
{
m = MATCH_NO;
goto cleanup;
}
for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
if (seen[d] > 1)
{
switch (d)
{
case DECL_ALLOCATABLE:
attr = "ALLOCATABLE";
break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
case DECL_EXTERNAL:
attr = "EXTERNAL";
break;
case DECL_IN:
attr = "INTENT (IN)";
break;
case DECL_OUT:
attr = "INTENT (OUT)";
break;
case DECL_INOUT:
attr = "INTENT (IN OUT)";
break;
case DECL_INTRINSIC:
attr = "INTRINSIC";
break;
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
case DECL_POINTER:
attr = "POINTER";
break;
case DECL_PRIVATE:
attr = "PRIVATE";
break;
case DECL_PUBLIC:
attr = "PUBLIC";
break;
case DECL_SAVE:
attr = "SAVE";
break;
case DECL_TARGET:
attr = "TARGET";
break;
default:
attr = NULL;
}
gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
m = MATCH_ERROR;
goto cleanup;
}
for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
{
if (seen[d] == 0)
continue;
if (gfc_current_state () == COMP_DERIVED
&& d != DECL_DIMENSION && d != DECL_POINTER
&& d != DECL_COLON && d != DECL_NONE)
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
&seen_at[d]);
m = MATCH_ERROR;
goto cleanup;
}
switch (d)
{
case DECL_ALLOCATABLE:
t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
break;
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_EXTERNAL:
t = gfc_add_external (¤t_attr, &seen_at[d]);
break;
case DECL_IN:
t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
break;
case DECL_OUT:
t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
break;
case DECL_INOUT:
t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
break;
case DECL_INTRINSIC:
t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
break;
case DECL_OPTIONAL:
t = gfc_add_optional (¤t_attr, &seen_at[d]);
break;
case DECL_PARAMETER:
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
case DECL_POINTER:
t = gfc_add_pointer (¤t_attr, &seen_at[d]);
break;
case DECL_PRIVATE:
t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
&seen_at[d]);
break;
case DECL_PUBLIC:
t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
&seen_at[d]);
break;
case DECL_SAVE:
t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_TARGET:
t = gfc_add_target (¤t_attr, &seen_at[d]);
break;
default:
gfc_internal_error ("match_attr_spec(): Bad attribute");
}
if (t == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
colon_seen = 1;
return MATCH_YES;
cleanup:
gfc_current_locus = start;
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
}
match
gfc_match_data_decl (void)
{
gfc_symbol *sym;
match m;
m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
{
sym = gfc_use_derived (current_ts.derived);
if (sym == NULL)
{
m = MATCH_ERROR;
goto cleanup;
}
current_ts.derived = sym;
}
m = match_attr_spec ();
if (m == MATCH_ERROR)
{
m = MATCH_NO;
goto cleanup;
}
if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
{
if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
goto ok;
if (gfc_find_symbol (current_ts.derived->name,
current_ts.derived->ns->parent, 1, &sym) == 0)
goto ok;
if (sym != NULL && sym->attr.flavor == FL_DERIVED)
goto ok;
gfc_error ("Derived type at %C has not been previously defined");
m = MATCH_ERROR;
goto cleanup;
}
ok:
if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
gfc_match_char (',');
for (;;)
{
m = variable_decl ();
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
break;
if (gfc_match_eos () == MATCH_YES)
goto cleanup;
if (gfc_match_char (',') != MATCH_YES)
break;
}
gfc_error ("Syntax error in data declaration at %C");
m = MATCH_ERROR;
cleanup:
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
}
static match
match_prefix (gfc_typespec * ts)
{
int seen_type;
gfc_clear_attr (¤t_attr);
seen_type = 0;
loop:
if (!seen_type && ts != NULL
&& match_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
seen_type = 1;
goto loop;
}
if (gfc_match ("elemental% ") == MATCH_YES)
{
if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
if (gfc_match ("pure% ") == MATCH_YES)
{
if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
if (gfc_match ("recursive% ") == MATCH_YES)
{
if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
return MATCH_YES;
}
static try
copy_prefix (symbol_attribute * dest, locus * where)
{
if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
return FAILURE;
if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
return FAILURE;
if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
return FAILURE;
return SUCCESS;
}
match
gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
head = tail = NULL;
if (gfc_match_char ('(') != MATCH_YES)
{
if (null_flag)
goto ok;
return MATCH_NO;
}
if (gfc_match_char (')') == MATCH_YES)
goto ok;
for (;;)
{
if (gfc_match_char ('*') == MATCH_YES)
sym = NULL;
else
{
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
if (gfc_get_symbol (name, NULL, &sym))
goto cleanup;
}
p = gfc_get_formal_arglist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = p;
}
tail->sym = sym;
if (sym != NULL && !st_flag
&& (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
|| gfc_missing_attr (&sym->attr, NULL) == FAILURE))
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_new_block != NULL && sym != NULL
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
gfc_error ("Name '%s' at %C is the name of the procedure",
sym->name);
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_match_char (')') == MATCH_YES)
goto ok;
m = gfc_match_char (',');
if (m != MATCH_YES)
{
gfc_error ("Unexpected junk in formal argument list at %C");
goto cleanup;
}
}
ok:
if (head != NULL)
{
for (p = head; p->next; p = p->next)
{
if (p->sym == NULL)
continue;
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
gfc_error
("Duplicate symbol '%s' in formal argument list at %C",
p->sym->name);
m = MATCH_ERROR;
goto cleanup;
}
}
}
if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
return MATCH_YES;
cleanup:
gfc_free_formal_arglist (head);
return m;
}
static match
match_result (gfc_symbol * function, gfc_symbol ** result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *r;
match m;
if (gfc_match (" result (") != MATCH_YES)
return MATCH_NO;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
if (gfc_match (" )%t") != MATCH_YES)
{
gfc_error ("Unexpected junk following RESULT variable at %C");
return MATCH_ERROR;
}
if (strcmp (function->name, name) == 0)
{
gfc_error
("RESULT variable at %C must be different than function name");
return MATCH_ERROR;
}
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
|| gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
return MATCH_YES;
}
match
gfc_match_function_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym, *result;
locus old_loc;
match m;
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
gfc_clear_ts (¤t_ts);
old_loc = gfc_current_locus;
m = match_prefix (¤t_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
return m;
}
if (gfc_match ("function% %n", name) != MATCH_YES)
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
if (get_proc_name (name, &sym))
return MATCH_ERROR;
gfc_new_block = sym;
m = gfc_match_formal_arglist (sym, 0, 0);
if (m == MATCH_NO)
gfc_error ("Expected formal argument list in function definition at %C");
else if (m == MATCH_ERROR)
goto cleanup;
result = NULL;
if (gfc_match_eos () != MATCH_YES)
{
m = match_result (sym, &result);
if (m == MATCH_NO)
gfc_error ("Unexpected junk after function declaration at %C");
if (m != MATCH_YES)
{
m = MATCH_ERROR;
goto cleanup;
}
}
m = MATCH_ERROR;
if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
|| copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
goto cleanup;
if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
{
gfc_error ("Function '%s' at %C already has a type of %s", name,
gfc_basic_typename (sym->ts.type));
goto cleanup;
}
if (result == NULL)
{
sym->ts = current_ts;
sym->result = sym;
}
else
{
result->ts = current_ts;
sym->result = result;
}
return MATCH_YES;
cleanup:
gfc_current_locus = old_loc;
return m;
}
match
gfc_match_entry (void)
{
gfc_symbol *proc;
gfc_symbol *result;
gfc_symbol *entry;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_compile_state state;
match m;
gfc_entry_list *el;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
state = gfc_current_state ();
if (state != COMP_SUBROUTINE
&& state != COMP_FUNCTION)
{
gfc_error ("ENTRY statement at %C cannot appear within %s",
gfc_state_name (gfc_current_state ()));
return MATCH_ERROR;
}
if (gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
{
gfc_error("ENTRY statement at %C cannot appear in a "
"contained procedure");
return MATCH_ERROR;
}
if (get_proc_name (name, &entry))
return MATCH_ERROR;
proc = gfc_current_block ();
if (state == COMP_SUBROUTINE)
{
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
|| gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
}
else
{
m = gfc_match_formal_arglist (entry, 0, 0);
if (m != MATCH_YES)
return MATCH_ERROR;
result = NULL;
if (gfc_match_eos () == MATCH_YES)
{
if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
|| gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
entry->result = entry;
}
else
{
m = match_result (proc, &result);
if (m == MATCH_NO)
gfc_syntax_error (ST_ENTRY);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
|| gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
|| gfc_add_function (&entry->attr, result->name,
NULL) == FAILURE)
return MATCH_ERROR;
entry->result = result;
}
if (proc->attr.recursive && result == NULL)
{
gfc_error ("RESULT attribute required in ENTRY statement at %C");
return MATCH_ERROR;
}
}
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_ENTRY);
return MATCH_ERROR;
}
entry->attr.recursive = proc->attr.recursive;
entry->attr.elemental = proc->attr.elemental;
entry->attr.pure = proc->attr.pure;
el = gfc_get_entry_list ();
el->sym = entry;
el->next = gfc_current_ns->entries;
gfc_current_ns->entries = el;
if (el->next)
el->id = el->next->id + 1;
else
el->id = 1;
new_st.op = EXEC_ENTRY;
new_st.ext.entry = el;
return MATCH_YES;
}
match
gfc_match_subroutine (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
m = match_prefix (NULL);
if (m != MATCH_YES)
return m;
m = gfc_match ("subroutine% %n", name);
if (m != MATCH_YES)
return m;
if (get_proc_name (name, &sym))
return MATCH_ERROR;
gfc_new_block = sym;
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_SUBROUTINE);
return MATCH_ERROR;
}
if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
static int
contained_procedure (void)
{
gfc_state_data *s;
for (s=gfc_state_stack; s; s=s->previous)
if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
&& s->previous != NULL
&& s->previous->state == COMP_CONTAINS)
return 1;
return 0;
}
match
gfc_match_end (gfc_statement * st)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_compile_state state;
locus old_loc;
const char *block_name;
const char *target;
int eos_ok;
match m;
old_loc = gfc_current_locus;
if (gfc_match ("end") != MATCH_YES)
return MATCH_NO;
state = gfc_current_state ();
block_name =
gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
if (state == COMP_CONTAINS)
{
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL ? NULL
: gfc_state_stack->previous->sym->name;
}
switch (state)
{
case COMP_NONE:
case COMP_PROGRAM:
*st = ST_END_PROGRAM;
target = " program";
eos_ok = 1;
break;
case COMP_SUBROUTINE:
*st = ST_END_SUBROUTINE;
target = " subroutine";
eos_ok = !contained_procedure ();
break;
case COMP_FUNCTION:
*st = ST_END_FUNCTION;
target = " function";
eos_ok = !contained_procedure ();
break;
case COMP_BLOCK_DATA:
*st = ST_END_BLOCK_DATA;
target = " block data";
eos_ok = 1;
break;
case COMP_MODULE:
*st = ST_END_MODULE;
target = " module";
eos_ok = 1;
break;
case COMP_INTERFACE:
*st = ST_END_INTERFACE;
target = " interface";
eos_ok = 0;
break;
case COMP_DERIVED:
*st = ST_END_TYPE;
target = " type";
eos_ok = 0;
break;
case COMP_IF:
*st = ST_ENDIF;
target = " if";
eos_ok = 0;
break;
case COMP_DO:
*st = ST_ENDDO;
target = " do";
eos_ok = 0;
break;
case COMP_SELECT:
*st = ST_END_SELECT;
target = " select";
eos_ok = 0;
break;
case COMP_FORALL:
*st = ST_END_FORALL;
target = " forall";
eos_ok = 0;
break;
case COMP_WHERE:
*st = ST_END_WHERE;
target = " where";
eos_ok = 0;
break;
default:
gfc_error ("Unexpected END statement at %C");
goto cleanup;
}
if (gfc_match_eos () == MATCH_YES)
{
if (!eos_ok)
{
gfc_error ("%s statement expected at %L",
gfc_ascii_statement (*st), &old_loc);
goto cleanup;
}
return MATCH_YES;
}
if (gfc_match (target) != MATCH_YES)
{
gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
goto cleanup;
}
if (gfc_match_eos () == MATCH_YES)
{
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
return MATCH_YES;
if (gfc_current_block () == NULL)
return MATCH_YES;
gfc_error ("Expected block name of '%s' in %s statement at %C",
block_name, gfc_ascii_statement (*st));
return MATCH_ERROR;
}
if (*st == ST_END_INTERFACE)
return gfc_match_end_interface ();
m = gfc_match_space ();
if (m == MATCH_YES)
m = gfc_match_name (name);
if (m == MATCH_NO)
gfc_error ("Expected terminating name at %C");
if (m != MATCH_YES)
goto cleanup;
if (block_name == NULL)
goto syntax;
if (strcmp (name, block_name) != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
syntax:
gfc_syntax_error (*st);
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
static match
attr_decl1 (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_array_spec *as;
gfc_symbol *sym;
locus var_locus;
match m;
as = NULL;
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
if (find_special (name, &sym))
return MATCH_ERROR;
var_locus = gfc_current_locus;
if (current_attr.dimension
|| current_attr.allocatable
|| current_attr.pointer
|| current_attr.target)
{
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
if (current_attr.dimension && m == MATCH_NO)
{
gfc_error
("Missing array specification at %L in DIMENSION statement",
&var_locus);
m = MATCH_ERROR;
goto cleanup;
}
if ((current_attr.allocatable || current_attr.pointer)
&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
{
gfc_error ("Array specification must be deferred at %L",
&var_locus);
m = MATCH_ERROR;
goto cleanup;
}
}
if (current_attr.dimension == 0
&& gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if ((current_attr.external || current_attr.intrinsic)
&& sym->attr.flavor != FL_PROCEDURE
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
return MATCH_YES;
cleanup:
gfc_free_array_spec (as);
return m;
}
static match
attr_decl (void)
{
match m;
gfc_match (" ::");
for (;;)
{
m = attr_decl1 ();
if (m != MATCH_YES)
break;
if (gfc_match_eos () == MATCH_YES)
{
m = MATCH_YES;
break;
}
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Unexpected character in variable list at %C");
m = MATCH_ERROR;
break;
}
}
return m;
}
match
gfc_match_external (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_external (¤t_attr, NULL);
return attr_decl ();
}
match
gfc_match_intent (void)
{
sym_intent intent;
intent = match_intent_spec ();
if (intent == INTENT_UNKNOWN)
return MATCH_ERROR;
gfc_clear_attr (¤t_attr);
gfc_add_intent (¤t_attr, intent, NULL);
return attr_decl ();
}
match
gfc_match_intrinsic (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_intrinsic (¤t_attr, NULL);
return attr_decl ();
}
match
gfc_match_optional (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_optional (¤t_attr, NULL);
return attr_decl ();
}
match
gfc_match_pointer (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_pointer (¤t_attr, NULL);
return attr_decl ();
}
match
gfc_match_allocatable (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_allocatable (¤t_attr, NULL);
return attr_decl ();
}
match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_dimension (¤t_attr, NULL, NULL);
return attr_decl ();
}
match
gfc_match_target (void)
{
gfc_clear_attr (¤t_attr);
gfc_add_target (¤t_attr, NULL);
return attr_decl ();
}
static match
access_attr_decl (gfc_statement st)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_user_op *uop;
gfc_symbol *sym;
gfc_intrinsic_op operator;
match m;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
goto done;
for (;;)
{
m = gfc_match_generic_spec (&type, name, &operator);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return MATCH_ERROR;
switch (type)
{
case INTERFACE_NAMELESS:
goto syntax;
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
if (gfc_add_access (&sym->attr,
(st ==
ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;
case INTERFACE_INTRINSIC_OP:
if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
{
gfc_current_ns->operator_access[operator] =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
}
else
{
gfc_error ("Access specification of the %s operator at %C has "
"already been specified", gfc_op2string (operator));
goto done;
}
break;
case INTERFACE_USER_OP:
uop = gfc_get_uop (name);
if (uop->access == ACCESS_UNKNOWN)
{
uop->access =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
}
else
{
gfc_error
("Access specification of the .%s. operator at %C has "
"already been specified", sym->name);
goto done;
}
break;
}
if (gfc_match_char (',') == MATCH_NO)
break;
}
if (gfc_match_eos () != MATCH_YES)
goto syntax;
return MATCH_YES;
syntax:
gfc_syntax_error (st);
done:
return MATCH_ERROR;
}
match
gfc_match_private (gfc_statement * st)
{
if (gfc_match ("private") != MATCH_YES)
return MATCH_NO;
if (gfc_current_state () == COMP_DERIVED)
{
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_PRIVATE;
return MATCH_YES;
}
gfc_syntax_error (ST_PRIVATE);
return MATCH_ERROR;
}
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_PRIVATE;
return MATCH_YES;
}
*st = ST_ATTR_DECL;
return access_attr_decl (ST_PRIVATE);
}
match
gfc_match_public (gfc_statement * st)
{
if (gfc_match ("public") != MATCH_YES)
return MATCH_NO;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_PUBLIC;
return MATCH_YES;
}
*st = ST_ATTR_DECL;
return access_attr_decl (ST_PUBLIC);
}
static match
do_parm (void)
{
gfc_symbol *sym;
gfc_expr *init;
match m;
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_NO)
gfc_error ("Expected variable name at %C in PARAMETER statement");
if (m != MATCH_YES)
return m;
if (gfc_match_char ('=') == MATCH_NO)
{
gfc_error ("Expected = sign in PARAMETER statement at %C");
return MATCH_ERROR;
}
m = gfc_match_init_expr (&init);
if (m == MATCH_NO)
gfc_error ("Expected expression at %C in PARAMETER statement");
if (m != MATCH_YES)
return m;
if (sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (sym, 1, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_check_assign_symbol (sym, init) == FAILURE
|| gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
sym->value = init;
return MATCH_YES;
cleanup:
gfc_free_expr (init);
return m;
}
match
gfc_match_parameter (void)
{
match m;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
for (;;)
{
m = do_parm ();
if (m != MATCH_YES)
break;
if (gfc_match (" )%t") == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Unexpected characters in PARAMETER statement at %C");
m = MATCH_ERROR;
break;
}
}
return m;
}
match
gfc_match_save (void)
{
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_common_head *c;
gfc_symbol *sym;
match m;
if (gfc_match_eos () == MATCH_YES)
{
if (gfc_current_ns->seen_save)
{
gfc_error ("Blanket SAVE statement at %C follows previous "
"SAVE statement");
return MATCH_ERROR;
}
gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
return MATCH_YES;
}
if (gfc_current_ns->save_all)
{
gfc_error ("SAVE statement at %C follows blanket SAVE statement");
return MATCH_ERROR;
}
gfc_match (" ::");
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_YES:
if (gfc_add_save (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
case MATCH_NO:
break;
case MATCH_ERROR:
return MATCH_ERROR;
}
m = gfc_match (" / %n /", &n);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;
c = gfc_get_common (n, 0);
c->saved = 1;
gfc_current_ns->seen_save = 1;
next_item:
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in SAVE statement at %C");
return MATCH_ERROR;
}
match
gfc_match_modproc (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
if (gfc_state_stack->state != COMP_INTERFACE
|| gfc_state_stack->previous == NULL
|| current_interface.type == INTERFACE_NAMELESS)
{
gfc_error
("MODULE PROCEDURE at %C must be in a generic module interface");
return MATCH_ERROR;
}
for (;;)
{
m = gfc_match_name (name);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
return MATCH_ERROR;
if (sym->attr.proc != PROC_MODULE
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_interface (sym) == FAILURE)
return MATCH_ERROR;
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_syntax_error (ST_MODULE_PROC);
return MATCH_ERROR;
}
match
gfc_match_derived_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
match m;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
gfc_clear_attr (&attr);
loop:
if (gfc_match (" , private") == MATCH_YES)
{
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error
("Derived type at %C can only be PRIVATE within a MODULE");
return MATCH_ERROR;
}
if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
if (gfc_match (" , public") == MATCH_YES)
{
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
return MATCH_ERROR;
}
if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
m = gfc_match (" %n%t", name);
if (m != MATCH_YES)
return m;
if (strcmp (name, "integer") == 0
|| strcmp (name, "real") == 0
|| strcmp (name, "character") == 0
|| strcmp (name, "logical") == 0
|| strcmp (name, "complex") == 0)
{
gfc_error
("Type name '%s' at %C cannot be the same as an intrinsic type",
name);
return MATCH_ERROR;
}
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (sym->ts.type != BT_UNKNOWN)
{
gfc_error ("Derived type name '%s' at %C already has a basic type "
"of %s", sym->name, gfc_typename (&sym->ts));
return MATCH_ERROR;
}
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->components != NULL)
{
gfc_error
("Derived type definition of '%s' at %C has already been defined",
sym->name);
return MATCH_ERROR;
}
if (attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
return MATCH_YES;
}