Google Git
Sign in
gnu / gcc / refs/heads/releases/gcc-4.8 / . / gcc / fortran / decl.c
blob: e73e32d20cfaa99ff076834540c926bde3b68ee5 [file] [log] [blame]
/* Declaration statement matcher
Copyright (C) 2002-2013 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
#include "flags.h"
#include "constructor.h"
#include "tree.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
#define gfc_get_data_variable() XCNEW (gfc_data_variable)
#define gfc_get_data_value() XCNEW (gfc_data_value)
#define gfc_get_data() XCNEW (gfc_data)
static gfc_try set_binding_label (const char **, const char *, int);
/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
static int old_char_selector;
/* When variables acquire types and attributes from a declaration
statement, they get them from the following static variables. The
first part of a declaration sets these variables and the second
part copies these into symbol structures. */
static gfc_typespec current_ts;
static symbol_attribute current_attr;
static gfc_array_spec *current_as;
static int colon_seen;
/* The current binding label (if any). */
static const char* curr_binding_label;
/* Need to know how many identifiers are on the current data declaration
line in case we're given the BIND(C) attribute with a NAME= specifier. */
static int num_idents_on_line;
/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
can supply a name if the curr_binding_label is nil and NAME= was not. */
static int has_name_equals = 0;
/* Initializer of the previous enumerator. */
static gfc_expr *last_initializer;
/* History of all the enumerators is maintained, so that
kind values of all the enumerators could be updated depending
upon the maximum initialized value. */
typedef struct enumerator_history
{
gfc_symbol *sym;
gfc_expr *initializer;
struct enumerator_history *next;
}
enumerator_history;
/* Header of enum history chain. */
static enumerator_history *enum_history = NULL;
/* Pointer of enum history node containing largest initializer. */
static enumerator_history *max_enum = NULL;
/* gfc_new_block points to the symbol of a newly matched block. */
gfc_symbol *gfc_new_block;
bool gfc_matching_function;
/********************* DATA statement subroutines *********************/
static bool in_match_data = false;
bool
gfc_in_match_data (void)
{
return in_match_data;
}
static void
set_in_match_data (bool set_value)
{
in_match_data = set_value;
}
/* Free a gfc_data_variable structure and everything beneath it. */
static void
free_variable (gfc_data_variable *p)
{
gfc_data_variable *q;
for (; p; p = q)
{
q = p->next;
gfc_free_expr (p->expr);
gfc_free_iterator (&p->iter, 0);
free_variable (p->list);
free (p);
}
}
/* Free a gfc_data_value structure and everything beneath it. */
static void
free_value (gfc_data_value *p)
{
gfc_data_value *q;
for (; p; p = q)
{
q = p->next;
mpz_clear (p->repeat);
gfc_free_expr (p->expr);
free (p);
}
}
/* Free a list of gfc_data structures. */
void
gfc_free_data (gfc_data *p)
{
gfc_data *q;
for (; p; p = q)
{
q = p->next;
free_variable (p->var);
free_value (p->value);
free (p);
}
}
/* Free all data in a namespace. */
static void
gfc_free_data_all (gfc_namespace *ns)
{
gfc_data *d;
for (;ns->data;)
{
d = ns->data->next;
free (ns->data);
ns->data = d;
}
}
static match var_element (gfc_data_variable *);
/* Match a list of variables terminated by an iterator and a right
parenthesis. */
static match
var_list (gfc_data_variable *parent)
{
gfc_data_variable *tail, var;
match m;
m = var_element (&var);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;
tail = gfc_get_data_variable ();
*tail = var;
parent->list = tail;
for (;;)
{
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
m = gfc_match_iterator (&parent->iter, 1);
if (m == MATCH_YES)
break;
if (m == MATCH_ERROR)
return MATCH_ERROR;
m = var_element (&var);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;
tail->next = gfc_get_data_variable ();
tail = tail->next;
*tail = var;
}
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_DATA);
return MATCH_ERROR;
}
/* Match a single element in a data variable list, which can be a
variable-iterator list. */
static match
var_element (gfc_data_variable *new_var)
{
match m;
gfc_symbol *sym;
memset (new_var, 0, sizeof (gfc_data_variable));
if (gfc_match_char ('(') == MATCH_YES)
return var_list (new_var);
m = gfc_match_variable (&new_var->expr, 0);
if (m != MATCH_YES)
return m;
sym = new_var->expr->symtree->n.sym;
/* Symbol should already have an associated type. */
if (gfc_check_symbol_typed (sym, gfc_current_ns,
false, gfc_current_locus) == FAILURE)
return MATCH_ERROR;
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, "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_var->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
/* Match the top-level list of data variables. */
static match
top_var_list (gfc_data *d)
{
gfc_data_variable var, *tail, *new_var;
match m;
tail = NULL;
for (;;)
{
m = var_element (&var);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return MATCH_ERROR;
new_var = gfc_get_data_variable ();
*new_var = var;
if (tail == NULL)
d->var = new_var;
else
tail->next = new_var;
tail = new_var;
if (gfc_match_char ('/') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_syntax_error (ST_DATA);
gfc_free_data_all (gfc_current_ns);
return MATCH_ERROR;
}
static match
match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym, *dt_sym = NULL;
gfc_expr *expr;
match m;
locus old_loc;
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;
old_loc = gfc_current_locus;
/* Should this be a structure component, try to match it
before matching a name. */
m = gfc_match_rvalue (result);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
{
if (gfc_simplify_expr (*result, 0) == FAILURE)
m = MATCH_ERROR;
return m;
}
else if (m == MATCH_YES)
gfc_free_expr (*result);
gfc_current_locus = old_loc;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
if (gfc_find_symbol (name, NULL, 1, &sym))
return MATCH_ERROR;
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
if (sym == NULL
|| (sym->attr.flavor != FL_PARAMETER
&& (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
return gfc_match_structure_constructor (dt_sym, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
{
gfc_current_locus = old_loc;
m = gfc_match_init_expr (result);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_YES)
{
if (gfc_simplify_expr (*result, 0) == FAILURE)
m = MATCH_ERROR;
if ((*result)->expr_type == EXPR_CONSTANT)
return m;
else
{
gfc_error ("Invalid initializer %s in Data statement at %C", name);
return MATCH_ERROR;
}
}
}
*result = gfc_copy_expr (sym->value);
return MATCH_YES;
}
/* Match a list of values in a DATA statement. The leading '/' has
already been seen at this point. */
static match
top_val_list (gfc_data *data)
{
gfc_data_value *new_val, *tail;
gfc_expr *expr;
match m;
tail = NULL;
for (;;)
{
m = match_data_constant (&expr);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return MATCH_ERROR;
new_val = gfc_get_data_value ();
mpz_init (new_val->repeat);
if (tail == NULL)
data->value = new_val;
else
tail->next = new_val;
tail = new_val;
if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
{
tail->expr = expr;
mpz_set_ui (tail->repeat, 1);
}
else
{
mpz_set (tail->repeat, expr->value.integer);
gfc_free_expr (expr);
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);
gfc_free_data_all (gfc_current_ns);
return MATCH_ERROR;
}
/* Matches an old style initialization. */
static match
match_old_style_init (const char *name)
{
match m;
gfc_symtree *st;
gfc_symbol *sym;
gfc_data *newdata;
/* Set up data structure to hold initializers. */
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;
/* Match initial value list. This also eats the terminal '/'. */
m = top_val_list (newdata);
if (m != MATCH_YES)
{
free (newdata);
return m;
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization at %C is not allowed in a PURE procedure");
free (newdata);
return MATCH_ERROR;
}
gfc_unset_implicit_pure (gfc_current_ns->proc_name);
/* Mark the variable as having appeared in a data statement. */
if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
{
free (newdata);
return MATCH_ERROR;
}
/* Chain in namespace list of DATA initializers. */
newdata->next = gfc_current_ns->data;
gfc_current_ns->data = newdata;
return m;
}
/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
we are matching a DATA statement and are therefore issuing an error
if we encounter something unexpected, if not, we're trying to match
an old-style initialization expression of the form INTEGER I /2/. */
match
gfc_match_data (void)
{
gfc_data *new_data;
match m;
set_in_match_data (true);
for (;;)
{
new_data = gfc_get_data ();
new_data->where = gfc_current_locus;
m = top_var_list (new_data);
if (m != MATCH_YES)
goto cleanup;
m = top_val_list (new_data);
if (m != MATCH_YES)
goto cleanup;
new_data->next = gfc_current_ns->data;
gfc_current_ns->data = new_data;
if (gfc_match_eos () == MATCH_YES)
break;
gfc_match_char (','); /* Optional comma */
}
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;
}
gfc_unset_implicit_pure (gfc_current_ns->proc_name);
return MATCH_YES;
cleanup:
set_in_match_data (false);
gfc_free_data (new_data);
return MATCH_ERROR;
}
/************************ Declaration statements *********************/
/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
static gfc_try
merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
if ((from->type == AS_ASSUMED_RANK && to->corank)
|| (to->type == AS_ASSUMED_RANK && from->corank))
{
gfc_error ("The assumed-rank array at %C shall not have a codimension");
return FAILURE;
}
if (to->rank == 0 && from->rank > 0)
{
to->rank = from->rank;
to->type = from->type;
to->cray_pointee = from->cray_pointee;
to->cp_was_assumed = from->cp_was_assumed;
for (i = 0; i < to->corank; i++)
{
to->lower[from->rank + i] = to->lower[i];
to->upper[from->rank + i] = to->upper[i];
}
for (i = 0; i < from->rank; i++)
{
if (copy)
{
to->lower[i] = gfc_copy_expr (from->lower[i]);
to->upper[i] = gfc_copy_expr (from->upper[i]);
}
else
{
to->lower[i] = from->lower[i];
to->upper[i] = from->upper[i];
}
}
}
else if (to->corank == 0 && from->corank > 0)
{
to->corank = from->corank;
to->cotype = from->cotype;
for (i = 0; i < from->corank; i++)
{
if (copy)
{
to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
}
else
{
to->lower[to->rank + i] = from->lower[i];
to->upper[to->rank + i] = from->upper[i];
}
}
}
return SUCCESS;
}
/* Match an intent specification. Since this can only happen after an
INTENT word, a legal intent-spec must follow. */
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;
}
/* Matches a character length specification, which is either a
specification expression, '*', or ':'. */
static match
char_len_param_value (gfc_expr **expr, bool *deferred)
{
match m;
*expr = NULL;
*deferred = false;
if (gfc_match_char ('*') == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (':') == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "deferred type "
"parameter at %C") == FAILURE)
return MATCH_ERROR;
*deferred = true;
return MATCH_YES;
}
m = gfc_match_expr (expr);
if (m == MATCH_YES
&& gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
return MATCH_ERROR;
if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
{
if ((*expr)->value.function.actual
&& (*expr)->value.function.actual->expr->symtree)
{
gfc_expr *e;
e = (*expr)->value.function.actual->expr;
if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& e->expr_type == EXPR_VARIABLE)
{
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
goto syntax;
if (e->symtree->n.sym->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.u.cl
&& e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
goto syntax;
}
}
}
return m;
syntax:
gfc_error ("Conflict in attributes of function argument at %C");
return MATCH_ERROR;
}
/* A character length is a '*' followed by a literal integer or a
char_len_param_value in parenthesis. */
static match
match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
{
int length;
match m;
*deferred = false;
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)
{
if (obsolescent_check
&& gfc_notify_std (GFC_STD_F95_OBS,
"Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
*expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
}
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
m = char_len_param_value (expr, deferred);
if (m != MATCH_YES && gfc_matching_function)
{
gfc_undo_symbols ();
m = MATCH_YES;
}
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;
}
/* Special subroutine for finding a symbol. Check if the name is found
in the current name space. If not, and we're compiling a function or
subroutine and the parent compilation unit is an interface, then check
to see if the name we've been given is the name of the interface
(located in another namespace). */
static int
find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
{
gfc_state_data *s;
gfc_symtree *st;
int i;
i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
if (i == 0)
{
*result = st ? st->n.sym : NULL;
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; /* Nameless interface. */
if (strcmp (name, s->sym->name) == 0)
{
*result = s->sym;
return 0;
}
end:
return i;
}
/* Special subroutine for getting a symbol node associated with a
procedure name, used in SUBROUTINE and FUNCTION statements. The
symbol is created in the parent using with symtree node in the
child unit pointing to the symbol. If the current namespace has no
parent, then the symbol is just created in the current unit. */
static int
get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
{
gfc_symtree *st;
gfc_symbol *sym;
int rc = 0;
/* Module functions have to be left in their own namespace because
they have potentially (almost certainly!) already been referenced.
In this sense, they are rather like external functions. This is
fixed up in resolve.c(resolve_entries), where the symbol name-
space is set to point to the master function, so that the fake
result mechanism can work. */
if (module_fcn_entry)
{
/* Present if entry is declared to be a module procedure. */
rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
if (*result == NULL)
rc = gfc_get_symbol (name, NULL, result);
else if (!gfc_get_symbol (name, NULL, &sym) && sym
&& (*result)->ts.type == BT_UNKNOWN
&& sym->attr.flavor == FL_UNKNOWN)
/* Pick up the typespec for the entry, if declared in the function
body. Note that this symbol is FL_UNKNOWN because it will
only have appeared in a type declaration. The local symtree
is set to point to the module symbol and a unique symtree
to the local version. This latter ensures a correct clearing
of the symbols. */
{
/* If the ENTRY proceeds its specification, we need to ensure
that this does not raise a "has no IMPLICIT type" error. */
if (sym->ts.type == BT_UNKNOWN)
sym->attr.untyped = 1;
(*result)->ts = sym->ts;
/* Put the symbol in the procedure namespace so that, should
the ENTRY precede its specification, the specification
can be applied. */
(*result)->ns = gfc_current_ns;
gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
st->n.sym = *result;
st = gfc_get_unique_symtree (gfc_current_ns);
st->n.sym = sym;
}
}
else
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
if (rc)
return rc;
sym = *result;
if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
{
/* Trap another encompassed procedure with the same name. All
these conditions are necessary to avoid picking up an entry
whose name clashes with that of the encompassing procedure;
this is handled using gsymbols to register unique,globally
accessible names. */
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);
/* Trap a procedure with a name the same as interface in the
encompassing scope. */
if (sym->attr.generic != 0
&& (sym->attr.subroutine || sym->attr.function)
&& !sym->attr.mod_proc)
gfc_error_now ("Name '%s' at %C is already defined"
" as a generic interface at %L",
name, &sym->declared_at);
/* Trap declarations of attributes in encompassing scope. The
signature for this is that ts.kind is set. Legitimate
references only set ts.type. */
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;
/* Module function entries will already have a symtree in
the current namespace but will need one at module level. */
if (module_fcn_entry)
{
/* Present if entry is declared to be a module procedure. */
rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
if (st == NULL)
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++;
/* See if the procedure should be a module procedure. */
if (((sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE)
|| (module_fcn_entry && sym->attr.proc != PROC_MODULE))
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
rc = 2;
return rc;
}
/* Verify that the given symbol representing a parameter is C
interoperable, by checking to see if it was marked as such after
its declaration. If the given symbol is not interoperable, a
warning is reported, thus removing the need to return the status to
the calling function. The standard does not require the user use
one of the iso_c_binding named constants to declare an
interoperable parameter, but we can't be sure if the param is C
interop or not if the user doesn't. For example, integer(4) may be
legal Fortran, but doesn't have meaning in C. It may interop with
a number of the C types, which causes a problem because the
compiler can't know which one. This code is almost certainly not
portable, and the user will get what they deserve if the C type
across platforms isn't always interoperable with integer(4). If
the user had used something like integer(c_int) or integer(c_long),
the compiler could have automatically handled the varying sizes
across platforms. */
gfc_try
gfc_verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
gfc_try retval = SUCCESS;
/* We check implicitly typed variables in symbol.c:gfc_set_default_type().
Don't repeat the checks here. */
if (sym->attr.implicit_type)
return SUCCESS;
/* For subroutines or functions that are passed to a BIND(C) procedure,
they're interoperable if they're BIND(C) and their params are all
interoperable. */
if (sym->attr.flavor == FL_PROCEDURE)
{
if (sym->attr.is_bind_c == 0)
{
gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
"attribute to be C interoperable", sym->name,
&(sym->declared_at));
return FAILURE;
}
else
{
if (sym->attr.is_c_interop == 1)
/* We've already checked this procedure; don't check it again. */
return SUCCESS;
else
return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
sym->common_block);
}
}
/* See if we've stored a reference to a procedure that owns sym. */
if (sym->ns != NULL && sym->ns->proc_name != NULL)
{
if (sym->ns->proc_name->attr.is_bind_c == 1)
{
is_c_interop = (gfc_verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0);
if (is_c_interop != 1)
{
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
gfc_error ("Variable '%s' at %L is a dummy argument to the "
"BIND(C) procedure '%s' but is not C interoperable "
"because derived type '%s' is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS)
gfc_error ("Variable '%s' at %L is a dummy argument to the "
"BIND(C) procedure '%s' but is not C interoperable "
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
else if (gfc_option.warn_c_binding_type)
gfc_warning ("Variable '%s' at %L is a dummy argument of the "
"BIND(C) procedure '%s' but may not be C "
"interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
}
/* Character strings are only C interoperable if they have a
length of 1. */
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
gfc_error ("Character argument '%s' at %L "
"must be length 1 because "
"procedure '%s' is BIND(C)",
sym->name, &sym->declared_at,
sym->ns->proc_name->name);
retval = FAILURE;
}
}
/* We have to make sure that any param to a bind(c) routine does
not have the allocatable, pointer, or optional attributes,
according to J3/04-007, section 5.1. */
if (sym->attr.allocatable == 1)
{
gfc_error ("Variable '%s' at %L cannot have the "
"ALLOCATABLE attribute because procedure '%s'"
" is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = FAILURE;
}
if (sym->attr.pointer == 1)
{
gfc_error ("Variable '%s' at %L cannot have the "
"POINTER attribute because procedure '%s'"
" is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = FAILURE;
}
if (sym->attr.optional == 1 && sym->attr.value)
{
gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
"and the VALUE attribute because procedure '%s' "
"is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = FAILURE;
}
else if (sym->attr.optional == 1
&& gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' "
"at %L with OPTIONAL attribute in "
"procedure '%s' which is BIND(C)",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name)
== FAILURE)
retval = FAILURE;
/* Make sure that if it has the dimension attribute, that it is
either assumed size or explicit shape. Deferred shape is already
covered by the pointer/allocatable attribute. */
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
&& gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
"at %L as dummy argument to the BIND(C) "
"procedure '%s' at %L", sym->name,
&(sym->declared_at), sym->ns->proc_name->name,
&(sym->ns->proc_name->declared_at)) == FAILURE)
retval = FAILURE;
}
}
return retval;
}
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
gfc_symbol *sym;
if (gfc_get_symbol (name, NULL, &sym))
return FAILURE;
/* Start updating the symbol table. Add basic type attribute if present. */
if (current_ts.type != BT_UNKNOWN
&& (sym->attr.implicit_type == 0
|| !gfc_compare_types (&sym->ts, &current_ts))
&& gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
{
sym->ts.u.cl = cl;
sym->ts.deferred = cl_deferred;
}
/* Add dimension attribute if present. */
if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
return FAILURE;
*as = NULL;
/* Add attribute to symbol. The copy is so that we can reset the
dimension attribute. */
attr = current_attr;
attr.dimension = 0;
attr.codimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
/* Finish any work that may need to be done for the binding label,
if it's a bind(c). The bind(c) attr is found before the symbol
is made, and before the symbol name (for data decls), so the
current_ts is holding the binding label, or nothing if the
name= attr wasn't given. Therefore, test here if we're dealing
with a bind(c) and make sure the binding label is set correctly. */
if (sym->attr.is_bind_c == 1)
{
if (!sym->binding_label)
{
/* Set the binding label and verify that if a NAME= was specified
then only one identifier was in the entity-decl-list. */
if (set_binding_label (&sym->binding_label, sym->name,
num_idents_on_line) == FAILURE)
return FAILURE;
}
}
/* See if we know we're in a common block, and if it's a bind(c)
common then we need to make sure we're an interoperable type. */
if (sym->attr.in_common == 1)
{
/* Test the common block object. */
if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
&& sym->ts.is_c_interop != 1)
{
gfc_error_now ("Variable '%s' in common block '%s' at %C "
"must be declared with a C interoperable "
"kind since common block '%s' is BIND(C)",
sym->name, sym->common_block->name,
sym->common_block->name);
gfc_clear_error ();
}
}
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return SUCCESS;
}
/* Set character constant to the given length. The constant will be padded or
truncated. If we're inside an array constructor without a typespec, we
additionally check that all elements have the same length; check_len -1
means no checking. */
void
gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
{
gfc_char_t *s;
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER);
slen = expr->value.character.length;
if (len != slen)
{
s = gfc_get_wide_string (len + 1);
memcpy (s, expr->value.character.string,
MIN (len, slen) * sizeof (gfc_char_t));
if (len > slen)
gfc_wide_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);
/* Apply the standard by 'hand' otherwise it gets cleared for
initializers. */
if (check_len != -1 && slen != check_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, check_len);
s[len] = '\0';
free (expr->value.character.string);
expr->value.character.string = s;
expr->value.character.length = len;
}
}
/* Function to create and update the enumerator history
using the information passed as arguments.
Pointer "max_enum" is also updated, to point to
enum history node containing largest initializer.
SYM points to the symbol node of enumerator.
INIT points to its enumerator value. */
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 = XCNEW (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;
}
}
/* Function to free enum kind history. */
void
gfc_free_enum_history (void)
{
enumerator_history *current = enum_history;
enumerator_history *next;
while (current != NULL)
{
next = current->next;
free (current);
current = next;
}
max_enum = NULL;
enum_history = NULL;
}
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
static gfc_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, false))
return FAILURE;
attr = sym->attr;
/* If this symbol is confirming an implicit parameter type,
then an initialization expression is not allowed. */
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 (init == NULL)
{
/* An initializer is required for PARAMETER declarations. */
if (attr.flavor == FL_PARAMETER)
{
gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
return FAILURE;
}
}
else
{
/* If a variable appears in a DATA block, it cannot have an
initializer. */
if (sym->attr.data)
{
gfc_error ("Variable '%s' at %C with an initializer already "
"appears in a DATA statement", sym->name);
return FAILURE;
}
/* Check if the assignment can happen. This has to be put off
until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
&& init->ts.type == BT_CHARACTER)
{
/* Update symbol character length according initializer. */
if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
return FAILURE;
if (sym->ts.u.cl->length == NULL)
{
int clen;
/* If there are multiple CHARACTER variables declared on the
same line, we don't want them to share the same length. */
sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (sym->attr.flavor == FL_PARAMETER)
{
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
sym->ts.u.cl->length
= gfc_get_int_expr (gfc_default_integer_kind,
NULL, clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
gfc_constructor *c;
c = gfc_constructor_first (init->value.constructor);
clen = c->expr->value.character.length;
sym->ts.u.cl->length
= gfc_get_int_expr (gfc_default_integer_kind,
NULL, clen);
}
else if (init->ts.u.cl && init->ts.u.cl->length)
sym->ts.u.cl->length =
gfc_copy_expr (sym->value->ts.u.cl->length);
}
}
/* Update initializer character length according symbol. */
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
gfc_constructor *c;
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
for (c = gfc_constructor_first (init->value.constructor);
c; c = gfc_constructor_next (c))
gfc_set_constant_character_len (len, c->expr, -1);
}
}
}
/* If sym is implied-shape, set its upper bounds from init. */
if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
&& sym->as->type == AS_IMPLIED_SHAPE)
{
int dim;
if (init->rank == 0)
{
gfc_error ("Can't initialize implied-shape array at %L"
" with scalar", &sym->declared_at);
return FAILURE;
}
gcc_assert (sym->as->rank == init->rank);
/* Shape should be present, we get an initialization expression. */
gcc_assert (init->shape);
for (dim = 0; dim < sym->as->rank; ++dim)
{
int k;
gfc_expr* lower;
gfc_expr* e;
lower = sym->as->lower[dim];
if (lower->expr_type != EXPR_CONSTANT)
{
gfc_error ("Non-constant lower bound in implied-shape"
" declaration at %L", &lower->where);
return FAILURE;
}
/* All dimensions must be without upper bound. */
gcc_assert (!sym->as->upper[dim]);
k = lower->ts.kind;
e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
mpz_add (e->value.integer,
lower->value.integer, init->shape[dim]);
mpz_sub_ui (e->value.integer, e->value.integer, 1);
sym->as->upper[dim] = e;
}
sym->as->type = AS_EXPLICIT;
}
/* Need to check if the expression we initialized this
to was one of the iso_c_binding named constants. If so,
and we're a parameter (constant), let it be iso_c.
For example:
integer(c_int), parameter :: my_int = c_int
integer(my_int) :: my_int_2
If we mark my_int as iso_c (since we can see it's value
is equal to one of the named constants), then my_int_2
will be considered C interoperable. */
if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
{
sym->ts.is_iso_c |= init->ts.is_iso_c;
sym->ts.is_c_interop |= init->ts.is_c_interop;
/* attr bits needed for module files. */
sym->attr.is_iso_c |= init->ts.is_iso_c;
sym->attr.is_c_interop |= init->ts.is_c_interop;
if (init->ts.is_iso_c)
sym->ts.f90_type = init->ts.f90_type;
}
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
mpz_t size;
gfc_expr *array;
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
&& spec_size (sym->as, &size) == SUCCESS
&& mpz_cmp_si (size, 0) > 0)
{
array = gfc_get_array_expr (init->ts.type, init->ts.kind,
&init->where);
for (n = 0; n < (int)mpz_get_si (size); n++)
gfc_constructor_append_expr (&array->value.constructor,
n == 0
? init
: gfc_copy_expr (init),
&init->where);
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
init = array;
mpz_clear (size);
}
init->rank = sym->as->rank;
}
sym->value = init;
if (sym->attr.save == SAVE_NONE)
sym->attr.save = SAVE_IMPLICIT;
*initp = NULL;
}
return SUCCESS;
}
/* Function called by variable_decl() that adds a name to a structure
being built. */
static gfc_try
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
gfc_component *c;
gfc_try t = SUCCESS;
/* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.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;
if (c->ts.type == BT_CHARACTER)
c->ts.u.cl = cl;
c->attr = current_attr;
c->initializer = *init;
*init = NULL;
c->as = *as;
if (c->as != NULL)
{
if (c->as->corank)
c->attr.codimension = 1;
if (c->as->rank)
c->attr.dimension = 1;
}
*as = NULL;
/* Should this ever get more complicated, combine with similar section
in add_init_expr_to_sym into a separate function. */
if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer
&& c->ts.u.cl
&& c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len;
gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
len = mpz_get_si (c->ts.u.cl->length->value.integer);
if (c->initializer->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, c->initializer, -1);
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
gfc_constructor *ctor;
ctor = gfc_constructor_first (c->initializer->value.constructor);
if (ctor)
{
int first_len;
bool has_ts = (c->initializer->ts.u.cl
&& c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
length. This need not be the length of the LHS! */
gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
for ( ; ctor; ctor = gfc_constructor_next (ctor))
if (ctor->expr->expr_type == EXPR_CONSTANT)
{
gfc_set_constant_character_len (len, ctor->expr,
has_ts ? -1 : first_len);
ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
}
}
}
}
/* Check array components. */
if (!c->attr.dimension)
goto scalar;
if (c->attr.pointer)
{
if (c->as->type != AS_DEFERRED)
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
t = FAILURE;
}
}
else if (c->attr.allocatable)
{
if (c->as->type != AS_DEFERRED)
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
t = FAILURE;
}
}
else
{
if (c->as->type != AS_EXPLICIT)
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
t = FAILURE;
}
}
scalar:
if (c->ts.type == BT_CLASS)
{
bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
|| (!c->ts.u.derived->components
&& !c->ts.u.derived->attr.zero_comp);
gfc_try t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
if (t != FAILURE)
t = t2;
}
return t;
}
/* Match a 'NULL()', and possibly take care of some side effects. */
match
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
match m, m2 = MATCH_NO;
if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
{
locus old_loc;
char name[GFC_MAX_SYMBOL_LEN + 1];
if ((m2 = gfc_match (" null (")) != MATCH_YES)
return m2;
old_loc = gfc_current_locus;
if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
return MATCH_ERROR;
if (m2 != MATCH_YES
&& ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
return MATCH_ERROR;
if (m2 == MATCH_NO)
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
}
/* The NULL symbol now has to be/become an intrinsic function. */
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;
*result = gfc_get_null_expr (&gfc_current_locus);
/* Invalid per F2008, C512. */
if (m2 == MATCH_YES)
{
gfc_error ("NULL() initialization at %C may not have MOLD");
return MATCH_ERROR;
}
return MATCH_YES;
}
/* Match the initialization expr for a data pointer or procedure pointer. */
static match
match_pointer_init (gfc_expr **init, int procptr)
{
match m;
if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
return MATCH_ERROR;
}
gfc_unset_implicit_pure (gfc_current_ns->proc_name);
/* Match NULL() initialization. */
m = gfc_match_null (init);
if (m != MATCH_NO)
return m;
/* Match non-NULL initialization. */
gfc_matching_ptr_assignment = !procptr;
gfc_matching_procptr_assignment = procptr;
m = gfc_match_rvalue (init);
gfc_matching_ptr_assignment = 0;
gfc_matching_procptr_assignment = 0;
if (m == MATCH_ERROR)
return MATCH_ERROR;
else if (m == MATCH_NO)
{
gfc_error ("Error in pointer initialization at %C");
return MATCH_ERROR;
}
if (!procptr)
gfc_resolve_expr (*init);
if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
static gfc_try
check_function_name (char *name)
{
/* In functions that have a RESULT variable defined, the function name always
refers to function calls. Therefore, the name is not allowed to appear in
specification statements. When checking this, be careful about
'hidden' procedure pointer results ('ppr@'). */
if (gfc_current_state () == COMP_FUNCTION)
{
gfc_symbol *block = gfc_current_block ();
if (block && block->result && block->result != block
&& strcmp (block->result->name, "ppr@") != 0
&& strcmp (block->name, name) == 0)
{
gfc_error ("Function name '%s' not allowed at %C", name);
return FAILURE;
}
}
return SUCCESS;
}
/* Match a variable name with an optional initializer. When this
subroutine is called, a variable is expected to be parsed next.
Depending on what is happening at the moment, updates either the
symbol table or the current interface. */
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; /* Extra copy for Cray Pointees. */
gfc_charlen *cl;
bool cl_deferred;
locus var_locus;
match m;
gfc_try t;
gfc_symbol *sym;
initializer = NULL;
as = NULL;
cp_as = NULL;
/* When we get here, we've just matched a list of attributes and
maybe a type and a double colon. The next thing we expect to see
is the name of the symbol. */
m = gfc_match_name (name);
if (m != MATCH_YES)
goto cleanup;
var_locus = gfc_current_locus;
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as, true, true);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
else if (current_as
&& merge_array_spec (current_as, as, true) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_option.flag_cray_pointer)
cp_as = gfc_copy_array_spec (as);
/* At this point, we know for sure if the symbol is PARAMETER and can thus
determine (and check) whether it can be implied-shape. If it
was parsed as assumed-size, change it because PARAMETERs can not
be assumed-size. */
if (as)
{
if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
{
m = MATCH_ERROR;
gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
name, &var_locus);
goto cleanup;
}
if (as->type == AS_ASSUMED_SIZE && as->rank == 1
&& current_attr.flavor == FL_PARAMETER)
as->type = AS_IMPLIED_SHAPE;
if (as->type == AS_IMPLIED_SHAPE
&& gfc_notify_std (GFC_STD_F2008,
"Implied-shape array at %L",
&var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
char_len = NULL;
cl = NULL;
cl_deferred = false;
if (current_ts.type == BT_CHARACTER)
{
switch (match_char_length (&char_len, &cl_deferred, false))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
cl->length = char_len;
break;
/* Non-constant lengths need to be copied after the first
element. Also copy assumed lengths. */
case MATCH_NO:
if (elem > 1
&& (current_ts.u.cl->length == NULL
|| current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
{
cl = gfc_new_charlen (gfc_current_ns, NULL);
cl->length = gfc_copy_expr (current_ts.u.cl->length);
}
else
cl = current_ts.u.cl;
cl_deferred = current_ts.deferred;
break;
case MATCH_ERROR:
goto cleanup;
}
}
/* If this symbol has already shown up in a Cray Pointer declaration,
then we want to set the type & bail out. */
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.u.cl = cl;
sym->ts.u.derived = current_ts.u.derived;
sym->ts.is_c_interop = current_ts.is_c_interop;
sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES;
/* Check to see if we have an array specification. */
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.");
/* Fix the array spec. */
m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR)
goto cleanup;
}
}
goto cleanup;
}
else
{
gfc_free_array_spec (cp_as);
}
}
/* Procedure pointer as function result. */
if (gfc_current_state () == COMP_FUNCTION
&& strcmp ("ppr@", gfc_current_block ()->name) == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
strcpy (name, "ppr@");
if (gfc_current_state () == COMP_FUNCTION
&& strcmp (name, gfc_current_block ()->name) == 0
&& gfc_current_block ()->result
&& strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
strcpy (name, "ppr@");
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
optional initialization expression for this symbol, e.g. this is
perfectly legal:
integer, parameter :: i = huge(i)
This is only true for parameters or variables of a basic type.
For components of derived types, it is not true, so we don't
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (gfc_current_state () != COMP_DERIVED
&& build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (check_function_name (name) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
/* We allow old-style initializations of the form
integer i /2/, j(4) /3*3, 1/
(if no colon has been seen). These are different from data
statements in that initializers are only allowed to apply to the
variable immediately preceding, i.e.
integer i, j /1, 2/
is not allowed. Therefore we have to do some work manually, that
could otherwise be left to the matchers for DATA statements. */
if (!colon_seen && gfc_match (" /") == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
else if (gfc_current_state () == COMP_DERIVED)
{
gfc_error ("Invalid old style initialization for derived type "
"component at %C");
m = MATCH_ERROR;
goto cleanup;
}
return match_old_style_init (name);
}
/* The double colon must be present in order to have initializers.
Otherwise the statement is ambiguous with an assignment statement. */
if (colon_seen)
{
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 = match_pointer_init (&initializer, 0);
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_state_stack->state != COMP_DERIVED)
{
gfc_error ("Initialization of variable at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
if (current_attr.flavor != FL_PARAMETER
&& gfc_state_stack->state != COMP_DERIVED)
gfc_unset_implicit_pure (gfc_current_ns->proc_name);
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;
}
/* Add the initializer. Note that it is fine if initializer is
NULL here, because we sometimes also need to check if a
declaration *must* have an initialization expression. */
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 (&current_ts);
t = build_struct (name, cl, &initializer, &as);
}
m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
cleanup:
/* Free stuff up and return. */
gfc_free_expr (initializer);
gfc_free_array_spec (as);
return m;
}
/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
This assumes that the byte size is equal to the kind number for
non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
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;
/* Massage the kind numbers for complex types. */
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 (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
ts->kind = 8;
if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
{
if (ts->kind == 4)
{
if (gfc_option.flag_real4_kind == 8)
ts->kind = 8;
if (gfc_option.flag_real4_kind == 10)
ts->kind = 10;
if (gfc_option.flag_real4_kind == 16)
ts->kind = 16;
}
if (ts->kind == 8)
{
if (gfc_option.flag_real8_kind == 4)
ts->kind = 4;
if (gfc_option.flag_real8_kind == 10)
ts->kind = 10;
if (gfc_option.flag_real8_kind == 16)
ts->kind = 16;
}
}
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 a kind specification. Since kinds are generally optional, we
usually return MATCH_NO if something goes wrong. If a "kind="
string is found, then we know we have an error. */
match
gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
{
locus where, loc;
gfc_expr *e;
match m, n;
char c;
const char *msg;
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
where = loc = gfc_current_locus;
if (kind_expr_only)
goto kind_expr;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
/* Also gobbles optional text. */
if (gfc_match (" kind = ") == MATCH_YES)
m = MATCH_ERROR;
loc = gfc_current_locus;
kind_expr:
n = gfc_match_init_expr (&e);
if (n != MATCH_YES)
{
if (gfc_matching_function)
{
/* The function kind expression might include use associated or
imported parameters and try again after the specification
expressions..... */
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
m = MATCH_ERROR;
goto no_match;
}
gfc_free_expr (e);
gfc_undo_symbols ();
return MATCH_YES;
}
else
{
/* ....or else, the match is real. */
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;
}
/* Before throwing away the expression, let's see if we had a
C interoperable kind (and store the fact). */
if (e->ts.is_c_interop == 1)
{
/* Mark this as C interoperable if being declared with one
of the named constants from iso_c_binding. */
ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type;
}
gfc_free_expr (e);
e = NULL;
/* Ignore errors to this point, if we've gotten here. This means
we ignore the m=MATCH_ERROR from above. */
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));
gfc_current_locus = where;
return MATCH_ERROR;
}
/* Warn if, e.g., c_int is used for a REAL variable, but not
if, e.g., c_double is used for COMPLEX as the standard
explicitly says that the kind type parameter for complex and real
variable is the same, i.e. c_float == c_float_complex. */
if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
&& !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
|| (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
gfc_warning_now ("C kind type parameter is for type %s but type at %L "
"is %s", gfc_basic_typename (ts->f90_type), &where,
gfc_basic_typename (ts->type));
gfc_gobble_whitespace ();
if ((c = gfc_next_ascii_char ()) != ')'
&& (ts->type != BT_CHARACTER || c != ','))
{
if (ts->type == BT_CHARACTER)
gfc_error ("Missing right parenthesis or comma at %C");
else
gfc_error ("Missing right parenthesis at %C");
m = MATCH_ERROR;
}
else
/* All tests passed. */
m = MATCH_YES;
if(m == MATCH_ERROR)
gfc_current_locus = where;
if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
ts->kind = 8;
if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
{
if (ts->kind == 4)
{
if (gfc_option.flag_real4_kind == 8)
ts->kind = 8;
if (gfc_option.flag_real4_kind == 10)
ts->kind = 10;
if (gfc_option.flag_real4_kind == 16)
ts->kind = 16;
}
if (ts->kind == 8)
{
if (gfc_option.flag_real8_kind == 4)
ts->kind = 4;
if (gfc_option.flag_real8_kind == 10)
ts->kind = 10;
if (gfc_option.flag_real8_kind == 16)
ts->kind = 16;
}
}
/* Return what we know from the test(s). */
return m;
no_match:
gfc_free_expr (e);
gfc_current_locus = where;
return m;
}
static match
match_char_kind (int * kind, int * is_iso_c)
{
locus where;
gfc_expr *e;
match m, n;
const char *msg;
m = MATCH_NO;
e = NULL;
where = gfc_current_locus;
n = gfc_match_init_expr (&e);
if (n != MATCH_YES && gfc_matching_function)
{
/* The expression might include use-associated or imported
parameters and try again after the specification
expressions. */
gfc_free_expr (e);
gfc_undo_symbols ();
return MATCH_YES;
}
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, kind);
*is_iso_c = e->ts.is_iso_c;
if (msg != NULL)
{
gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
gfc_free_expr (e);
/* Ignore errors to this point, if we've gotten here. This means
we ignore the m=MATCH_ERROR from above. */
if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
{
gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
m = MATCH_ERROR;
}
else
/* All tests passed. */
m = MATCH_YES;
if (m == MATCH_ERROR)
gfc_current_locus = where;
/* Return what we know from the test(s). */
return m;
no_match:
gfc_free_expr (e);
gfc_current_locus = where;
return m;
}
/* Match the various kind/length specifications in a CHARACTER
declaration. We don't return MATCH_NO. */
match
gfc_match_char_spec (gfc_typespec *ts)
{
int kind, seen_length, is_iso_c;
gfc_charlen *cl;
gfc_expr *len;
match m;
bool deferred;
len = NULL;
seen_length = 0;
kind = 0;
is_iso_c = 0;
deferred = false;
/* Try the old-style specification first. */
old_char_selector = 0;
m = match_char_length (&len, &deferred, true);
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; /* Character without length is a single char. */
goto done;
}
/* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
if (gfc_match (" kind =") == MATCH_YES)
{
m = match_char_kind (&kind, &is_iso_c);
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, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto done;
seen_length = 1;
goto rparen;
}
/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
if (gfc_match (" len =") == MATCH_YES)
{
m = char_len_param_value (&len, &deferred);
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;
if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
goto done;
goto rparen;
}
/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
m = char_len_param_value (&len, &deferred);
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 ="); /* Gobble optional text. */
m = match_char_kind (&kind, &is_iso_c);
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
goto syntax;
rparen:
/* Require a right-paren at this point. */
m = gfc_match_char (')');
if (m == MATCH_YES)
goto done;
syntax:
gfc_error ("Syntax error in CHARACTER declaration at %C");
m = MATCH_ERROR;
gfc_free_expr (len);
return m;
done:
/* Deal with character functions after USE and IMPORT statements. */
if (gfc_matching_function)
{
gfc_free_expr (len);
gfc_undo_symbols ();
return MATCH_YES;
}
if (m != MATCH_YES)
{
gfc_free_expr (len);
return m;
}
/* Do some final massaging of the length values. */
cl = gfc_new_charlen (gfc_current_ns, NULL);
if (seen_length == 0)
cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
else
cl->length = len;
ts->u.cl = cl;
ts->kind = kind == 0 ? gfc_default_character_kind : kind;
ts->deferred = deferred;
/* We have to know if it was a C interoperable kind so we can
do accurate type checking of bind(c) procs, etc. */
if (kind != 0)
/* Mark this as C interoperable if being declared with one
of the named constants from iso_c_binding. */
ts->is_c_interop = is_iso_c;
else if (len != NULL)
/* Here, we might have parsed something such as: character(c_char)
In this case, the parsing code above grabs the c_char when
looking for the length (line 1690, roughly). it's the last
testcase for parsing the kind params of a character variable.
However, it's not actually the length. this seems like it
could be an error.
To see if the user used a C interop kind, test the expr
of the so called length, and see if it's C interoperable. */
ts->is_c_interop = len->ts.is_iso_c;
return MATCH_YES;
}
/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
structure to the matched specification. This is necessary for FUNCTION and
IMPLICIT statements.
If implicit_flag is nonzero, then we don't check for the optional
kind specification. Not doing so is needed for matching an IMPLICIT
statement correctly. */
match
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym, *dt_sym;
match m;
char c;
bool seen_deferred_kind, matched_type;
const char *dt_name;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
&& (gfc_current_block ()->result->ts.kind == -1)
&& (ts->kind == -1);
gfc_clear_ts (ts);
if (seen_deferred_kind)
ts->kind = -1;
/* Clear the current binding label, in case one is given. */
curr_binding_label = NULL;
if (gfc_match (" byte") == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_GNU, "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;
}
m = gfc_match (" type (");
matched_type = (m == MATCH_YES);
if (matched_type)
{
gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () == '*')
{
if ((m = gfc_match ("*)")) != MATCH_YES)
return m;
if (gfc_current_state () == COMP_DERIVED)
{
gfc_error ("Assumed type at %C is not allowed for components");
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
"at %C") == FAILURE)
return MATCH_ERROR;
ts->type = BT_ASSUMED;
return MATCH_YES;
}
m = gfc_match ("%n", name);
matched_type = (m == MATCH_YES);
}
if ((matched_type && strcmp ("integer", name) == 0)
|| (!matched_type && gfc_match (" integer") == MATCH_YES))
{
ts->type = BT_INTEGER;
ts->kind = gfc_default_integer_kind;
goto get_kind;
}
if ((matched_type && strcmp ("character", name) == 0)
|| (!matched_type && gfc_match (" character") == MATCH_YES))
{
if (matched_type
&& gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
m = gfc_match_char_spec (ts);
else
m = MATCH_YES;
if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
m = MATCH_ERROR;
return m;
}
if ((matched_type && strcmp ("real", name) == 0)
|| (!matched_type && gfc_match (" real") == MATCH_YES))
{
ts->type = BT_REAL;
ts->kind = gfc_default_real_kind;
goto get_kind;
}
if ((matched_type
&& (strcmp ("doubleprecision", name) == 0
|| (strcmp ("double", name) == 0
&& gfc_match (" precision") == MATCH_YES)))
|| (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
if (matched_type
&& gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
if ((matched_type && strcmp ("complex", name) == 0)
|| (!matched_type && gfc_match (" complex") == MATCH_YES))
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_complex_kind;
goto get_kind;
}
if ((matched_type
&& (strcmp ("doublecomplex", name) == 0
|| (strcmp ("double", name) == 0
&& gfc_match (" complex") == MATCH_YES)))
|| (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")
== FAILURE)
return MATCH_ERROR;
if (matched_type
&& gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
ts->type = BT_COMPLEX;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
if ((matched_type && strcmp ("logical", name) == 0)
|| (!matched_type && gfc_match (" logical") == MATCH_YES))
{
ts->type = BT_LOGICAL;
ts->kind = gfc_default_logical_kind;
goto get_kind;
}
if (matched_type)
m = gfc_match_char (')');
if (m == MATCH_YES)
ts->type = BT_DERIVED;
else
{
/* Match CLASS declarations. */
m = gfc_match (" class ( * )");
if (m == MATCH_ERROR)
return MATCH_ERROR;
else if (m == MATCH_YES)
{
gfc_symbol *upe;
gfc_symtree *st;
ts->type = BT_CLASS;
gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
if (upe == NULL)
{
upe = gfc_new_symbol ("STAR", gfc_current_ns);
st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe;
gfc_set_sym_referenced (upe);
upe->refs++;
upe->ts.type = BT_VOID;
upe->attr.unlimited_polymorphic = 1;
/* This is essential to force the construction of
unlimited polymorphic component class containers. */
upe->attr.zero_comp = 1;
if (gfc_add_flavor (&upe->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
}
else
{
st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR");
if (st == NULL)
st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe;
upe->refs++;
}
ts->u.derived = upe;
return m;
}
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")
== FAILURE)
return MATCH_ERROR;
}
/* Defer association of the derived type until the end of the
specification block. However, if the derived type can be
found, add it to the typespec. */
if (gfc_matching_function)
{
ts->u.derived = NULL;
if (gfc_current_state () != COMP_INTERFACE
&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
{
sym = gfc_find_dt_in_generic (sym);
ts->u.derived = sym;
}
return MATCH_YES;
}
/* Search for the name but allow the components to be defined later. If
type = -1, this typespec has been seen in a function declaration but
the type could not be accessed at that point. The actual derived type is
stored in a symtree with the first letter of the name capitalized; the
symtree with the all lower-case name contains the associated
generic function. */
dt_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) name[0]),
(const char*)&name[1]);
sym = NULL;
dt_sym = NULL;
if (ts->kind != -1)
{
gfc_get_ha_symbol (name, &sym);
if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->generic && !dt_sym)
dt_sym = gfc_find_dt_in_generic (sym);
}
else if (ts->kind == -1)
{
int iface = gfc_state_stack->previous->state != COMP_INTERFACE
|| gfc_current_ns->has_import_set;
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym && sym->generic && !dt_sym)
dt_sym = gfc_find_dt_in_generic (sym);
ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
if ((sym->attr.flavor != FL_UNKNOWN
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
gfc_error ("Type name '%s' at %C conflicts with previously declared "
"entity at %L, which has the same name", name,
&sym->declared_at);
return MATCH_ERROR;
}
gfc_save_symbol_data (sym);
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (!dt_sym)
{
gfc_interface *intr, *head;
/* Use upper case to save the actual derived-type symbol. */
gfc_get_symbol (dt_name, NULL, &dt_sym);
dt_sym->name = gfc_get_string (sym->name);
head = sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
intr->where = gfc_current_locus;
intr->next = head;
sym->generic = intr;
sym->attr.if_source = IFSRC_DECL;
}
else
gfc_save_symbol_data (dt_sym);
gfc_set_sym_referenced (dt_sym);
if (dt_sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
== FAILURE)
return MATCH_ERROR;
ts->u.derived = dt_sym;
return MATCH_YES;
get_kind:
if (matched_type
&& gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
/* For all types except double, derived and character, look for an
optional kind specifier. MATCH_NO is actually OK at this point. */
if (implicit_flag == 1)
{
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
return MATCH_YES;
}
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_ascii_char ();
if (!gfc_is_whitespace (c) && c != '*' && c != '('
&& c != ':' && c != ',')
{
if (matched_type && c == ')')
{
gfc_next_ascii_char ();
return MATCH_YES;
}
return MATCH_NO;
}
}
m = gfc_match_kind_spec (ts, false);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
/* Defer association of the KIND expression of function results
until after USE and IMPORT statements. */
if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
|| gfc_matching_function)
return MATCH_YES;
if (m == MATCH_NO)
m = MATCH_YES; /* No kind specifier found. */
return m;
}
/* Match an IMPLICIT NONE statement. Actually, this statement is
already matched in parse.c, or we would not end up here in the
first place. So the only thing we need to check, is if there is
trailing garbage. If not, the match is successful. */
match
gfc_match_implicit_none (void)
{
return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
}
/* Match the letter range(s) of an IMPLICIT statement. */
static match
match_implicit_range (void)
{
char c, c1, c2;
int inner;
locus cur_loc;
cur_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_ascii_char ();
if (c != '(')
{
gfc_error ("Missing character range in IMPLICIT at %C");
goto bad;
}
inner = 1;
while (inner)
{
gfc_gobble_whitespace ();
c1 = gfc_next_ascii_char ();
if (!ISALPHA (c1))
goto bad;
gfc_gobble_whitespace ();
c = gfc_next_ascii_char ();
switch (c)
{
case ')':
inner = 0; /* Fall through. */
case ',':
c2 = c1;
break;
case '-':
gfc_gobble_whitespace ();
c2 = gfc_next_ascii_char ();
if (!ISALPHA (c2))
goto bad;
gfc_gobble_whitespace ();
c = gfc_next_ascii_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;
}
/* See if we can add the newly matched range to the pending
implicits from this IMPLICIT statement. We do not check for
conflicts with whatever earlier IMPLICIT statements may have
set. This is done when we've successfully finished matching
the current one. */
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 an IMPLICIT statement, storing the types for
gfc_set_implicit() if the statement is accepted by the parser.
There is a strange looking, but legal syntactic construction
possible. It looks like:
IMPLICIT INTEGER (a-b) (c-d)
This is legal if "a-b" is a constant expression that happens to
equal one of the legal kinds for integers. The real problem
happens with an implicit specification that looks like:
IMPLICIT INTEGER (a-b)
In this case, a typespec matcher that is "greedy" (as most of the
matchers are) gobbles the character range as a kindspec, leaving
nothing left. We therefore have to go a bit more slowly in the
matching process by inhibiting the kindspec checking during
typespec matching and checking for a kind later. */
match
gfc_match_implicit (void)
{
gfc_typespec ts;
locus cur_loc;
char c;
match m;
gfc_clear_ts (&ts);
/* We don't allow empty implicit statements. */
if (gfc_match_eos () == MATCH_YES)
{
gfc_error ("Empty IMPLICIT statement at %C");
return MATCH_ERROR;
}
do
{
/* First cleanup. */
gfc_clear_new_implicit ();
/* A basic type is mandatory here. */
m = gfc_match_decl_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)
{
/* We may have <TYPE> (<RANGE>). */
gfc_gobble_whitespace ();
c = gfc_next_ascii_char ();
if ((c == '\n') || (c == ','))
{
/* Check for CHARACTER with no length parameter. */
if (ts.type == BT_CHARACTER && !ts.u.cl)
{
ts.kind = gfc_default_character_kind;
ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1);
}
/* Record the Successful match. */
if (gfc_merge_new_implicit (&ts) != SUCCESS)
return MATCH_ERROR;
continue;
}
gfc_current_locus = cur_loc;
}
/* Discard the (incorrectly) matched range. */
gfc_clear_new_implicit ();
/* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
if (ts.type == BT_CHARACTER)
m = gfc_match_char_spec (&ts);
else
{
m = gfc_match_kind_spec (&ts, false);
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_ascii_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;
}
match
gfc_match_import (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
gfc_symbol *sym;
gfc_symtree *st;
if (gfc_current_ns->proc_name == NULL
|| gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_error ("IMPORT statement at %C only permitted in "
"an INTERFACE body");
return MATCH_ERROR;
}