#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;
static gfc_expr *last_initializer;
typedef struct enumerator_history
{
gfc_symbol *sym;
gfc_expr *initializer;
struct enumerator_history *next;
}
enumerator_history;
static enumerator_history *enum_history = NULL;
static enumerator_history *max_enum = NULL;
gfc_symbol *gfc_new_block;
static bool in_match_data = false;
bool
gfc_in_match_data (void)
{
return in_match_data;
}
void
gfc_set_in_match_data (bool set_value)
{
in_match_data = set_value;
}
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->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
{
gfc_error ("Host associated variable '%s' may not be in the DATA "
"statement at %C.", sym->name);
return MATCH_ERROR;
}
if (gfc_current_state () != COMP_BLOCK_DATA
&& sym->attr.in_common
&& gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
"common block variable '%s' in DATA statement at %C",
sym->name) == FAILURE)
return MATCH_ERROR;
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 ("%s", 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_symbol *sym;
gfc_data *newdata;
gfc_find_sym_tree (name, NULL, 0, &st);
sym = st->n.sym;
newdata = gfc_get_data ();
newdata->var = gfc_get_data_variable ();
newdata->var->expr = gfc_get_variable_expr (st);
newdata->where = gfc_current_locus;
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;
}
if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
{
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;
gfc_set_in_match_data (true);
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 (',');
}
gfc_set_in_match_data (false);
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_set_in_match_data (false);
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, NULL);
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;
int i;
i = gfc_get_symbol (name, NULL, result);
if (i==0)
goto end;
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
goto end;
s = gfc_state_stack->previous;
if (s == NULL)
goto end;
if (s->state != COMP_INTERFACE)
goto end;
if (s->sym == NULL)
goto end;
if (strcmp (name, s->sym->name) == 0)
{
*result = s->sym;
return 0;
}
end:
return i;
}
static int
get_proc_name (const char *name, gfc_symbol ** result,
bool module_fcn_entry)
{
gfc_symtree *st;
gfc_symbol *sym;
int rc;
if (module_fcn_entry)
rc = gfc_get_symbol (name, NULL, result);
else
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
sym = *result;
if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
{
if (sym->attr.flavor != 0
&& sym->attr.proc != 0
&& (sym->attr.subroutine || sym->attr.function)
&& sym->attr.if_source != IFSRC_UNKNOWN)
gfc_error_now ("Procedure '%s' at %C is already defined at %L",
name, &sym->declared_at);
if (sym->ts.kind != 0
&& !sym->attr.implicit_type
&& sym->attr.proc == 0
&& gfc_current_ns->parent != NULL
&& sym->attr.access == 0
&& !module_fcn_entry)
gfc_error_now ("Procedure '%s' at %C has an explicit interface"
" and must not have attributes declared at %L",
name, &sym->declared_at);
}
if (gfc_current_ns->parent == NULL || *result == NULL)
return rc;
if (module_fcn_entry)
st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
else
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
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) || module_fcn_entry)
&& 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 (gfc_get_symbol (name, NULL, &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, bool array)
{
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 + 1);
memcpy (s, expr->value.character.string, MIN (len, slen));
if (len > slen)
memset (&s[slen], ' ', len - slen);
if (gfc_option.warn_character_truncation && slen > len)
gfc_warning_now ("CHARACTER expression at %L is being truncated "
"(%d/%d)", &expr->where, slen, len);
if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
gfc_error_now ("The CHARACTER elements of the array constructor "
"at %L must have the same length (%d/%d)",
&expr->where, slen, len);
s[len] = '\0';
gfc_free (expr->value.character.string);
expr->value.character.string = s;
expr->value.character.length = len;
}
}
static void
create_enum_history (gfc_symbol *sym, gfc_expr *init)
{
enumerator_history *new_enum_history;
gcc_assert (sym != NULL && init != NULL);
new_enum_history = gfc_getmem (sizeof (enumerator_history));
new_enum_history->sym = sym;
new_enum_history->initializer = init;
new_enum_history->next = NULL;
if (enum_history == NULL)
{
enum_history = new_enum_history;
max_enum = enum_history;
}
else
{
new_enum_history->next = enum_history;
enum_history = new_enum_history;
if (mpz_cmp (max_enum->initializer->value.integer,
new_enum_history->initializer->value.integer) < 0)
max_enum = new_enum_history;
}
}
void
gfc_free_enum_history (void)
{
enumerator_history *current = enum_history;
enumerator_history *next;
while (current != NULL)
{
next = current->next;
gfc_free (current);
current = next;
}
max_enum = NULL;
enum_history = NULL;
}
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)
{
sym->ts.cl = gfc_get_charlen ();
sym->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl;
if (sym->attr.flavor == FL_PARAMETER
&& 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, false);
else if (init->expr_type == EXPR_ARRAY)
{
init->ts.cl = gfc_get_charlen ();
init->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl;
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, false);
}
}
}
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)
{
if (c->allocatable)
{
gfc_error ("Allocatable component at %C must be an array");
return FAILURE;
}
else
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->allocatable)
{
if (c->as->type != AS_DEFERRED)
{
gfc_error ("Allocatable 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 (int elem)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
gfc_array_spec *cp_as;
gfc_charlen *cl;
locus var_locus;
match m;
try t;
gfc_symbol *sym;
locus old_locus;
initializer = NULL;
as = NULL;
cp_as = NULL;
old_locus = gfc_current_locus;
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
var_locus = gfc_current_locus;
m = gfc_match_array_spec (&as);
if (gfc_option.flag_cray_pointer && m == MATCH_YES)
cp_as = gfc_copy_array_spec (as);
else 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:
if (elem > 1 && current_ts.cl->length
&& current_ts.cl->length->expr_type != EXPR_CONSTANT)
{
cl = gfc_get_charlen ();
cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = cl;
cl->length = gfc_copy_expr (current_ts.cl->length);
}
else
cl = current_ts.cl;
break;
case MATCH_ERROR:
goto cleanup;
}
}
if (gfc_option.flag_cray_pointer)
{
gfc_find_symbol (name, gfc_current_ns, 1, &sym);
if (sym != NULL && sym->attr.cray_pointee)
{
sym->ts.type = current_ts.type;
sym->ts.kind = current_ts.kind;
sym->ts.cl = cl;
sym->ts.derived = current_ts.derived;
m = MATCH_YES;
if (cp_as != NULL)
{
if (sym->as != NULL)
{
gfc_error ("Duplicate array spec for Cray pointee at %C.");
gfc_free_array_spec (cp_as);
m = MATCH_ERROR;
goto cleanup;
}
else
{
if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
gfc_internal_error ("Couldn't set pointee array spec.");
m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR)
goto cleanup;
}
}
goto cleanup;
}
else
{
gfc_free_array_spec (cp_as);
}
}
if (gfc_current_state () != COMP_DERIVED
&& build_sym (name, cl, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (current_ts.type == BT_DERIVED
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& current_ts.derived->ns != gfc_current_ns)
{
gfc_error ("the type of '%s' at %C has not been declared within the "
"interface", name);
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;
}
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 (initializer != NULL && current_attr.allocatable
&& gfc_current_state () == COMP_DERIVED)
{
gfc_error ("Initialization of allocatable component at %C is not allowed");
m = MATCH_ERROR;
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
&& !current_attr.pointer
&& !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;
int original_kind;
if (gfc_match_char ('*') != MATCH_YES)
return MATCH_NO;
m = gfc_match_small_literal_int (&ts->kind, NULL);
if (m != MATCH_YES)
return MATCH_ERROR;
original_kind = ts->kind;
if (ts->type == BT_COMPLEX)
{
if (ts->kind % 2)
{
gfc_error ("Old-style type declaration %s*%d not supported at %C",
gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
ts->kind /= 2;
}
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
gfc_error ("Old-style type declaration %s*%d not supported at %C",
gfc_basic_typename (ts->type), original_kind);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
gfc_basic_typename (ts->type), original_kind) == FAILURE)
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 ("%s", 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 (" byte") == MATCH_YES)
{
if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
== FAILURE)
return MATCH_ERROR;
if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
{
gfc_error ("BYTE type used at %C "
"is not available on the target machine");
return MATCH_ERROR;
}
ts->type = BT_INTEGER;
ts->kind = 1;
return MATCH_YES;
}
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)
{
if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
"conform to the Fortran 95 standard") == FAILURE)
return MATCH_ERROR;
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)
{
if (d == DECL_ALLOCATABLE)
{
if (gfc_notify_std (GFC_STD_F2003,
"In the selected standard, the ALLOCATABLE "
"attribute at %C is not allowed in a TYPE "
"definition") == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
else
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
&seen_at[d]);
m = MATCH_ERROR;
goto cleanup;
}
}
if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
&& gfc_current_state () != COMP_MODULE)
{
if (d == DECL_PRIVATE)
attr = "PRIVATE";
else
attr = "PUBLIC";
gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
attr, &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;
int elem;
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;
gfc_find_symbol (current_ts.derived->name,
current_ts.derived->ns->parent, 1, &sym);
if (sym != NULL && sym->attr.flavor == FL_DERIVED
&& current_ts.derived->components != NULL)
goto ok;
gfc_error_now ("Derived type at %C has not been previously defined "
"and so cannot appear in a derived type definition.");
current_attr.pointer = 1;
goto ok;
}
ok:
if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
gfc_match_char (',');
elem = 1;
for (;;)
{
m = variable_decl (elem++);
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;
}
if (gfc_error_flag_test () == 0)
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, false))
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");
m = MATCH_ERROR;
goto cleanup;
}
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
&& !sym->attr.implicit_type)
{
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;
}
static bool
add_global_entry (const char * name, int sub)
{
gfc_gsymbol *s;
s = gfc_get_gsymbol(name);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
return true;
}
return false;
}
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;
locus old_loc;
bool module_procedure;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
state = gfc_current_state ();
if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
switch (state)
{
case COMP_PROGRAM:
gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
break;
case COMP_MODULE:
gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
break;
case COMP_BLOCK_DATA:
gfc_error
("ENTRY statement at %C cannot appear within a BLOCK DATA");
break;
case COMP_INTERFACE:
gfc_error
("ENTRY statement at %C cannot appear within an INTERFACE");
break;
case COMP_DERIVED:
gfc_error
("ENTRY statement at %C cannot appear "
"within a DERIVED TYPE block");
break;
case COMP_IF:
gfc_error
("ENTRY statement at %C cannot appear within an IF-THEN block");
break;
case COMP_DO:
gfc_error
("ENTRY statement at %C cannot appear within a DO block");
break;
case COMP_SELECT:
gfc_error
("ENTRY statement at %C cannot appear within a SELECT block");
break;
case COMP_FORALL:
gfc_error
("ENTRY statement at %C cannot appear within a FORALL block");
break;
case COMP_WHERE:
gfc_error
("ENTRY statement at %C cannot appear within a WHERE block");
break;
case COMP_CONTAINS:
gfc_error
("ENTRY statement at %C cannot appear "
"within a contained subprogram");
break;
default:
gfc_internal_error ("gfc_match_entry(): Bad state");
}
return MATCH_ERROR;
}
module_procedure = gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
if (gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& !module_procedure)
{
gfc_error("ENTRY statement at %C cannot appear in a "
"contained procedure");
return MATCH_ERROR;
}
if (get_proc_name (name, &entry,
gfc_current_ns->parent != NULL
&& module_procedure
&& gfc_current_ns->proc_name->attr.function))
return MATCH_ERROR;
proc = gfc_current_block ();
if (state == COMP_SUBROUTINE)
{
if (!add_global_entry (name, 1))
return MATCH_ERROR;
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
{
if (!add_global_entry (name, 0))
return MATCH_ERROR;
old_loc = gfc_current_locus;
if (gfc_match_eos () == MATCH_YES)
{
gfc_current_locus = old_loc;
m = gfc_match_formal_arglist (entry, 0, 1);
}
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 (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, false))
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;
}
static void
set_enum_kind(void)
{
enumerator_history *current_history = NULL;
int kind;
int i;
if (max_enum == NULL || enum_history == NULL)
return;
if (!gfc_option.fshort_enums)
return;
i = 0;
do
{
kind = gfc_integer_kinds[i++].kind;
}
while (kind < gfc_c_int_kind
&& gfc_check_integer_range (max_enum->initializer->value.integer,
kind) != ARITH_OK);
current_history = enum_history;
while (current_history != NULL)
{
current_history->sym->ts.kind = kind;
current_history = current_history->next;
}
}
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;
case COMP_ENUM:
*st = ST_END_ENUM;
target = " enum";
eos_ok = 0;
last_initializer = NULL;
set_enum_kind ();
gfc_free_enum_history ();
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 (sym->attr.cray_pointee && sym->as != NULL)
{
m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR)
goto cleanup;
}
if (gfc_add_attribute (&sym->attr, &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;
}
static match
cray_pointer_decl (void)
{
match m;
gfc_array_spec *as;
gfc_symbol *cptr;
gfc_symbol *cpte;
locus var_locus;
bool done = false;
while (!done)
{
if (gfc_match_char ('(') != MATCH_YES)
{
gfc_error ("Expected '(' at %C");
return MATCH_ERROR;
}
var_locus = gfc_current_locus;
gfc_clear_attr (¤t_attr);
gfc_add_cray_pointer (¤t_attr, &var_locus);
current_ts.type = BT_INTEGER;
current_ts.kind = gfc_index_integer_kind;
m = gfc_match_symbol (&cptr, 0);
if (m != MATCH_YES)
{
gfc_error ("Expected variable name at %C");
return m;
}
if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
return MATCH_ERROR;
gfc_set_sym_referenced (cptr);
if (cptr->ts.type == BT_UNKNOWN)
{
cptr->ts.type = BT_INTEGER;
cptr->ts.kind = gfc_index_integer_kind;
}
else if (cptr->ts.type != BT_INTEGER)
{
gfc_error ("Cray pointer at %C must be an integer.");
return MATCH_ERROR;
}
else if (cptr->ts.kind < gfc_index_integer_kind)
gfc_warning ("Cray pointer at %C has %d bytes of precision;"
" memory addresses require %d bytes.",
cptr->ts.kind,
gfc_index_integer_kind);
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Expected \",\" at %C");
return MATCH_ERROR;
}
var_locus = gfc_current_locus;
gfc_clear_attr (¤t_attr);
gfc_add_cray_pointee (¤t_attr, &var_locus);
current_ts.type = BT_UNKNOWN;
current_ts.kind = 0;
m = gfc_match_symbol (&cpte, 0);
if (m != MATCH_YES)
{
gfc_error ("Expected variable name at %C");
return m;
}
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
{
gfc_free_array_spec (as);
return m;
}
else if (m == MATCH_NO)
{
gfc_free_array_spec (as);
as = NULL;
}
if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
return MATCH_ERROR;
gfc_set_sym_referenced (cpte);
if (cpte->as == NULL)
{
if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
gfc_internal_error ("Couldn't set Cray pointee array spec.");
}
else if (as != NULL)
{
gfc_error ("Duplicate array spec for Cray pointee at %C.");
gfc_free_array_spec (as);
return MATCH_ERROR;
}
as = NULL;
if (cpte->as != NULL)
{
m = gfc_mod_pointee_as (cpte->as);
if (m == MATCH_ERROR)
return m;
}
cpte->cp_pointer = cptr;
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Expected \")\" at %C");
return MATCH_ERROR;
}
m = gfc_match_char (',');
if (m != MATCH_YES)
done = true;
}
if (m == MATCH_ERROR
|| gfc_match_eos () != MATCH_YES)
{
gfc_error ("Expected \",\" or end of statement at %C");
return MATCH_ERROR;
}
return MATCH_YES;
}
match
gfc_match_external (void)
{
gfc_clear_attr (¤t_attr);
current_attr.external = 1;
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);
current_attr.intent = intent;
return attr_decl ();
}
match
gfc_match_intrinsic (void)
{
gfc_clear_attr (¤t_attr);
current_attr.intrinsic = 1;
return attr_decl ();
}
match
gfc_match_optional (void)
{
gfc_clear_attr (¤t_attr);
current_attr.optional = 1;
return attr_decl ();
}
match
gfc_match_pointer (void)
{
gfc_gobble_whitespace ();
if (gfc_peek_char () == '(')
{
if (!gfc_option.flag_cray_pointer)
{
gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
" flag.");
return MATCH_ERROR;
}
return cray_pointer_decl ();
}
else
{
gfc_clear_attr (¤t_attr);
current_attr.pointer = 1;
return attr_decl ();
}
}
match
gfc_match_allocatable (void)
{
gfc_clear_attr (¤t_attr);
current_attr.allocatable = 1;
return attr_decl ();
}
match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
current_attr.dimension = 1;
return attr_decl ();
}
match
gfc_match_target (void)
{
gfc_clear_attr (¤t_attr);
current_attr.target = 1;
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;
}
if (sym->ts.type == BT_CHARACTER
&& sym->ts.cl != NULL
&& sym->ts.cl->length != NULL
&& sym->ts.cl->length->expr_type == EXPR_CONSTANT
&& init->expr_type == EXPR_CONSTANT
&& init->ts.type == BT_CHARACTER
&& init->ts.kind == 1)
gfc_set_constant_character_len (
mpz_get_si (sym->ts.cl->length->value.integer), init, false);
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)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Blanket SAVE statement at %C follows previous "
"SAVE statement")
== FAILURE)
return MATCH_ERROR;
}
gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
return MATCH_YES;
}
if (gfc_current_ns->save_all)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"SAVE statement at %C follows blanket SAVE statement")
== FAILURE)
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;
sym->attr.mod_proc = 1;
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;
}
try
gfc_mod_pointee_as (gfc_array_spec *as)
{
as->cray_pointee = true;
if (as->type == AS_ASSUMED_SIZE)
{
as->type = AS_EXPLICIT;
as->upper[as->rank - 1] = gfc_int_expr (1);
as->cp_was_assumed = true;
}
else if (as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Cray Pointee at %C cannot be assumed shape array");
return MATCH_ERROR;
}
return MATCH_YES;
}
match
gfc_match_enum (void)
{
match m;
m = gfc_match_eos ();
if (m != MATCH_YES)
return m;
if (gfc_notify_std (GFC_STD_F2003,
"New in Fortran 2003: ENUM and ENUMERATOR at %C")
== FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
static match
enumerator_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer;
gfc_array_spec *as = NULL;
gfc_symbol *sym;
locus var_locus;
match m;
try t;
locus old_locus;
initializer = NULL;
old_locus = gfc_current_locus;
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
var_locus = gfc_current_locus;
if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (colon_seen)
{
if (gfc_match_char ('=') == MATCH_YES)
{
m = gfc_match_init_expr (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Expected an initialization expression at %C");
m = MATCH_ERROR;
}
if (m != MATCH_YES)
goto cleanup;
}
}
if (initializer == NULL)
initializer = gfc_enum_initializer (last_initializer, old_locus);
if (initializer == NULL || initializer->ts.type != BT_INTEGER)
{
gfc_error("ENUMERATOR %L not initialized with integer expression",
&var_locus);
m = MATCH_ERROR;
gfc_free_enum_history ();
goto cleanup;
}
last_initializer = initializer;
t = add_init_expr_to_sym (name, &initializer, &var_locus);
gfc_find_symbol (name, NULL, 0, &sym);
create_enum_history (sym, last_initializer);
return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
cleanup:
gfc_free_expr (initializer);
return m;
}
match
gfc_match_enumerator_def (void)
{
match m;
try t;
gfc_clear_ts (¤t_ts);
m = gfc_match (" enumerator");
if (m != MATCH_YES)
return m;
m = gfc_match (" :: ");
if (m == MATCH_ERROR)
return m;
colon_seen = (m == MATCH_YES);
if (gfc_current_state () != COMP_ENUM)
{
gfc_error ("ENUM definition statement expected before %C");
gfc_free_enum_history ();
return MATCH_ERROR;
}
(¤t_ts)->type = BT_INTEGER;
(¤t_ts)->kind = gfc_c_int_kind;
gfc_clear_attr (¤t_attr);
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
if (t == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
for (;;)
{
m = enumerator_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;
}
if (gfc_current_state () == COMP_ENUM)
{
gfc_free_enum_history ();
gfc_error ("Syntax error in ENUMERATOR definition at %C");
m = MATCH_ERROR;
}
cleanup:
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
}