/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "match.h"
#include "parse.h"
#include "flags.h"
-
+#include "constructor.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
gfc_free_expr (p->expr);
gfc_free_iterator (&p->iter, 0);
free_variable (p->list);
- gfc_free (p);
+ free (p);
}
}
for (; p; p = q)
{
q = p->next;
+ mpz_clear (p->repeat);
gfc_free_expr (p->expr);
- gfc_free (p);
+ free (p);
}
}
q = p->next;
free_variable (p->var);
free_value (p->value);
- gfc_free (p);
+ free (p);
}
}
for (;ns->data;)
{
d = ns->data->next;
- gfc_free (ns->data);
+ free (ns->data);
ns->data = d;
}
}
m = top_val_list (newdata);
if (m != MATCH_YES)
{
- gfc_free (newdata);
+ free (newdata);
return m;
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization at %C is not allowed in a PURE procedure");
- gfc_free (newdata);
+ free (newdata);
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Mark the variable as having appeared in a data statement. */
if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
{
- gfc_free (newdata);
+ free (newdata);
return MATCH_ERROR;
}
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
cleanup:
/************************ Declaration statements *********************/
+
+/* Auxilliary function to merge DIMENSION and CODIMENSION array specs. */
+
+static void
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+ int i;
+
+ 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];
+ }
+ }
+ }
+}
+
+
/* Match an intent specification. Since this can only happen after an
INTENT word, a legal intent-spec must follow. */
/* Matches a character length specification, which is either a
- specification expression or a '*'. */
+ specification expression, '*', or ':'. */
static match
-char_len_param_value (gfc_expr **expr)
+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)
{
- *expr = NULL;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+ "parameter at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ *deferred = true;
+
return MATCH_YES;
}
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr **expr)
+match_char_length (gfc_expr **expr, bool *deferred)
{
int length;
match m;
+ *deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
- *expr = gfc_int_expr (length);
+ *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);
+ m = char_len_param_value (expr, deferred);
if (m != MATCH_YES && gfc_matching_function)
{
gfc_undo_symbols ();
across platforms. */
gfc_try
-verify_c_interop_param (gfc_symbol *sym)
+gfc_verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
gfc_try retval = SUCCESS;
{
if (sym->ns->proc_name->attr.is_bind_c == 1)
{
- is_c_interop =
- (verify_c_interop (&(sym->ts))
- == SUCCESS ? 1 : 0);
+ 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 ("Type '%s' at %L is a parameter to the BIND(C) "
- " procedure '%s' but is not C interoperable "
+ 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
gfc_warning ("Variable '%s' at %L is a parameter to the "
"BIND(C) procedure '%s' but may not be C "
retval = FAILURE;
}
- if (sym->attr.optional == 1)
+ if (sym->attr.optional == 1 && sym->attr.value)
{
- gfc_error ("Variable '%s' at %L cannot have the "
- "OPTIONAL attribute because procedure '%s'"
- " is BIND(C)", sym->name, &(sym->declared_at),
+ 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, "TS29113: 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. */
}
-/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
- A CLASS entity is represented by an encapsulating type, which contains the
- declared type as '$data' component, plus an integer component '$vindex'
- which determines the dynamic type, and another integer '$size', which
- contains the size of the dynamic type structure. */
-
-static gfc_try
-encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as)
-{
- char name[GFC_MAX_SYMBOL_LEN + 5];
- gfc_symbol *fclass;
- gfc_component *c;
-
- /* Determine the name of the encapsulating type. */
- if ((*as) && (*as)->rank && attr->allocatable)
- sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
- else if ((*as) && (*as)->rank)
- sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
- else if (attr->allocatable)
- sprintf (name, ".class.%s.a", ts->u.derived->name);
- else
- sprintf (name, ".class.%s", ts->u.derived->name);
-
- gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
- if (fclass == NULL)
- {
- gfc_symtree *st;
- /* If not there, create a new symbol. */
- fclass = gfc_new_symbol (name, ts->u.derived->ns);
- st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
- st->n.sym = fclass;
- gfc_set_sym_referenced (fclass);
- fclass->refs++;
- fclass->ts.type = BT_UNKNOWN;
- fclass->vindex = ts->u.derived->vindex;
- fclass->attr.abstract = ts->u.derived->attr.abstract;
- if (ts->u.derived->f2k_derived)
- fclass->f2k_derived = gfc_get_namespace (NULL, 0);
- if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
- return FAILURE;
-
- /* Add component '$data'. */
- if (gfc_add_component (fclass, "$data", &c) == FAILURE)
- return FAILURE;
- c->ts = *ts;
- c->ts.type = BT_DERIVED;
- c->attr.access = ACCESS_PRIVATE;
- c->ts.u.derived = ts->u.derived;
- c->attr.pointer = attr->pointer || attr->dummy;
- c->attr.allocatable = attr->allocatable;
- c->attr.dimension = attr->dimension;
- c->attr.abstract = ts->u.derived->attr.abstract;
- c->as = (*as);
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
-
- /* Add component '$vindex'. */
- if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
- return FAILURE;
- c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
- c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_int_expr (0);
-
- /* Add component '$size'. */
- if (gfc_add_component (fclass, "$size", &c) == FAILURE)
- return FAILURE;
- c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
- c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_int_expr (0);
- }
-
- fclass->attr.extension = 1;
- fclass->attr.is_class = 1;
- ts->u.derived = fclass;
- attr->allocatable = attr->pointer = attr->dimension = 0;
- (*as) = NULL; /* XXX */
- return SUCCESS;
-}
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
-build_sym (const char *name, gfc_charlen *cl,
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
- sym->ts.u.cl = cl;
+ {
+ 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)
dimension attribute. */
attr = current_attr;
attr.dimension = 0;
+ attr.codimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
- {
- sym->attr.class_ok = (sym->attr.dummy
- || sym->attr.pointer
- || sym->attr.allocatable) ? 1 : 0;
- encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
- }
+ return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return SUCCESS;
}
&expr->where, slen, check_len);
s[len] = '\0';
- gfc_free (expr->value.character.string);
+ free (expr->value.character.string);
expr->value.character.string = s;
expr->value.character.length = len;
}
while (current != NULL)
{
next = current->next;
- gfc_free (current);
+ free (current);
current = next;
}
max_enum = NULL;
}
/* Check if the assignment can happen. This has to be put off
- until later for a derived type variable. */
+ 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, init) == FAILURE)
return FAILURE;
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
- gfc_expr *p = init->value.constructor->expr;
- clen = p->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ 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 =
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
- gfc_constructor * p;
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 (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, -1);
+ 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
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;
- gfc_constructor *c;
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_start_constructor (init->ts.type, init->ts.kind,
- &init->where);
-
- array->value.constructor = c = NULL;
+ array = gfc_get_array_expr (init->ts.type, init->ts.kind,
+ &init->where);
for (n = 0; n < (int)mpz_get_si (size); n++)
- {
- if (array->value.constructor == NULL)
- {
- array->value.constructor = c = gfc_get_constructor ();
- c->expr = init;
- }
- else
- {
- c->next = gfc_get_constructor ();
- c = c->next;
- c->expr = gfc_copy_expr (init);
- }
- }
-
+ 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]);
c->as = *as;
if (c->as != NULL)
- c->attr.dimension = 1;
+ {
+ 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
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
- bool has_ts;
- gfc_constructor *ctor = c->initializer->value.constructor;
-
- has_ts = (c->initializer->ts.u.cl
- && c->initializer->ts.u.cl->length_from_typespec);
+ 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
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
- for (; ctor; ctor = ctor->next)
+ for ( ; ctor; ctor = gfc_constructor_next (ctor))
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
{
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
+ 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);
}
}
}
scalar:
if (c->ts.type == BT_CLASS)
- encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+ {
+ bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
+ || (!c->ts.u.derived->components
+ && !c->ts.u.derived->attr.zero_comp);
+ return gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
+ }
return t;
}
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
- gfc_expr *e;
match m;
m = gfc_match (" null ( )");
|| 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 = gfc_get_null_expr (&gfc_current_locus);
+
+ 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;
+ }
+
+ /* Match NULL() initilization. */
+ 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;
+ }
- *result = e;
+ if (!procptr)
+ gfc_resolve_expr (*init);
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 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
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;
var_locus = gfc_current_locus;
/* Now we could see the optional array spec. or character length. */
- 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)
+ 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);
+
+ 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,
+ "Fortran 2008: 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))
+ switch (match_char_length (&char_len, &cl_deferred))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
else
cl = current_ts.u.cl;
+ cl_deferred = current_ts.deferred;
+
break;
case MATCH_ERROR:
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, &as, &var_locus) == FAILURE)
+ && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
specified in the procedure definition, except that the interface
may specify a procedure that is not pure if the procedure is
defined to be pure(12.3.2). */
- if (current_ts.type == BT_DERIVED
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& current_ts.u.derived->ns != gfc_current_ns)
goto cleanup;
}
}
-
- /* 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. */
- 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)
+
+ if (check_function_name (name) == FAILURE)
{
- gfc_error ("Function name '%s' not allowed at %C", name);
m = MATCH_ERROR;
goto cleanup;
}
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_state_stack->state != COMP_DERIVED)
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 0);
if (m != MATCH_YES)
goto cleanup;
-
}
else if (gfc_match_char ('=') == MATCH_YES)
{
m = MATCH_ERROR;
}
- if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
+ 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");
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);
+ m = match_char_length (&len, &deferred);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
if (gfc_match (" , len =") == MATCH_NO)
goto rparen;
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
if (gfc_match (" len =") == MATCH_YES)
{
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
}
/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
cl = gfc_new_charlen (gfc_current_ns, NULL);
if (seen_length == 0)
- cl->length = gfc_int_expr (1);
+ 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. */
gfc_symbol *sym;
match m;
char c;
- bool seen_deferred_kind;
+ bool seen_deferred_kind, matched_type;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
return MATCH_YES;
}
- if (gfc_match (" integer") == MATCH_YES)
+
+ m = gfc_match (" type ( %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 (gfc_match (" character") == MATCH_YES)
+ if ((matched_type && strcmp ("character", name) == 0)
+ || (!matched_type && gfc_match (" character") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
- return gfc_match_char_spec (ts);
+ m = gfc_match_char_spec (ts);
else
- return MATCH_YES;
+ m = MATCH_YES;
+
+ if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+ m = MATCH_ERROR;
+
+ return m;
}
- if (gfc_match (" real") == MATCH_YES)
+ 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 (gfc_match (" double precision") == MATCH_YES)
+ 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, "Fortran 2008: 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 (gfc_match (" complex") == 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 (gfc_match (" double complex") == MATCH_YES)
+ 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 does not "
- "conform to the Fortran 95 standard") == FAILURE)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 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;
return MATCH_YES;
}
- if (gfc_match (" logical") == 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;
}
- m = gfc_match (" type ( %n )", name);
+ 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_fatal_error ("Unlimited polymorphism at %C not yet supported");
+ return MATCH_ERROR;
+ }
+
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
return MATCH_YES;
get_kind:
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 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)
- return MATCH_YES;
+ {
+ 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 != ',')
- return MATCH_NO;
+ {
+ 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 ())
{
ts.kind = gfc_default_character_kind;
ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- ts.u.cl->length = gfc_int_expr (1);
+ ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
/* Record the Successful match. */
for(;;)
{
+ sym = NULL;
m = gfc_match (" %n", name);
switch (m)
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
- else if (gfc_current_ns->proc_name->ns->parent != NULL
+ else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
&& gfc_find_symbol (name,
gfc_current_ns->proc_name->ns->parent,
1, &sym))
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
- DECL_IS_BIND_C, DECL_NONE,
- GFC_DECL_END /* Sentinel */
+ DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+ DECL_NONE, GFC_DECL_END /* Sentinel */
}
decl_types;
switch (gfc_peek_ascii_char ())
{
case 'a':
- if (match_string_p ("allocatable"))
- d = DECL_ALLOCATABLE;
+ gfc_next_ascii_char ();
+ switch (gfc_next_ascii_char ())
+ {
+ case 'l':
+ if (match_string_p ("locatable"))
+ {
+ /* Matched "allocatable". */
+ d = DECL_ALLOCATABLE;
+ }
+ break;
+
+ case 's':
+ if (match_string_p ("ynchronous"))
+ {
+ /* Matched "asynchronous". */
+ d = DECL_ASYNCHRONOUS;
+ }
+ break;
+ }
break;
case 'b':
goto cleanup;
break;
+ case 'c':
+ gfc_next_ascii_char ();
+ if ('o' != gfc_next_ascii_char ())
+ break;
+ switch (gfc_next_ascii_char ())
+ {
+ case 'd':
+ if (match_string_p ("imension"))
+ {
+ d = DECL_CODIMENSION;
+ break;
+ }
+ case 'n':
+ if (match_string_p ("tiguous"))
+ {
+ d = DECL_CONTIGUOUS;
+ break;
+ }
+ }
+ break;
+
case 'd':
if (match_string_p ("dimension"))
d = DECL_DIMENSION;
seen[d]++;
seen_at[d] = gfc_current_locus;
- if (d == DECL_DIMENSION)
+ if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
{
- m = gfc_match_array_spec (¤t_as);
+ gfc_array_spec *as = NULL;
+
+ m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+ d == DECL_CODIMENSION);
+
+ if (current_as == NULL)
+ current_as = as;
+ else if (m == MATCH_YES)
+ {
+ merge_array_spec (as, current_as, false);
+ free (as);
+ }
if (m == MATCH_NO)
{
- gfc_error ("Missing dimension specification at %C");
+ if (d == DECL_CODIMENSION)
+ gfc_error ("Missing codimension specification at %C");
+ else
+ gfc_error ("Missing dimension specification at %C");
m = MATCH_ERROR;
}
case DECL_ALLOCATABLE:
attr = "ALLOCATABLE";
break;
+ case DECL_ASYNCHRONOUS:
+ attr = "ASYNCHRONOUS";
+ break;
+ case DECL_CODIMENSION:
+ attr = "CODIMENSION";
+ break;
+ case DECL_CONTIGUOUS:
+ attr = "CONTIGUOUS";
+ break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
continue;
if (gfc_current_state () == COMP_DERIVED
- && d != DECL_DIMENSION && d != DECL_POINTER
- && d != DECL_PRIVATE && d != DECL_PUBLIC
- && d != DECL_NONE)
+ && d != DECL_DIMENSION && d != DECL_CODIMENSION
+ && d != DECL_POINTER && d != DECL_PRIVATE
+ && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
{
if (d == DECL_ALLOCATABLE)
{
t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
break;
+ case DECL_ASYNCHRONOUS:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: ASYNCHRONOUS attribute at %C")
+ == FAILURE)
+ t = FAILURE;
+ else
+ t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
+ break;
+
+ case DECL_CODIMENSION:
+ t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
+ break;
+
+ case DECL_CONTIGUOUS:
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: CONTIGUOUS attribute at %C")
+ == FAILURE)
+ t = FAILURE;
+ else
+ t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
}
}
+ /* Module variables implicitly have the SAVE attribute. */
+ if (gfc_current_state () == COMP_MODULE && !current_attr.save)
+ current_attr.save = SAVE_IMPLICIT;
+
colon_seen = 1;
return MATCH_YES;
/* Verify that the given gfc_typespec is for a C interoperable type. */
gfc_try
-verify_c_interop (gfc_typespec *ts)
+gfc_verify_c_interop (gfc_typespec *ts)
{
if (ts->type == BT_DERIVED && ts->u.derived != NULL)
- return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
+ ? SUCCESS : FAILURE;
+ else if (ts->type == BT_CLASS)
+ return FAILURE;
else if (ts->is_c_interop != 1)
return FAILURE;
the given ts (current_ts), so look in both. */
if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
{
- if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
+ if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
{
/* See if we're dealing with a sym in a common block or not. */
if (is_in_common == 1)
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
+ bool seen_impure;
+ bool found_prefix;
gfc_clear_attr (¤t_attr);
- seen_type = 0;
+ seen_type = false;
+ seen_impure = false;
gcc_assert (!gfc_matching_prefix);
gfc_matching_prefix = true;
-loop:
- if (!seen_type && ts != NULL
- && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
- && gfc_match_space () == MATCH_YES)
+ do
{
+ found_prefix = false;
- seen_type = 1;
- goto loop;
- }
+ if (!seen_type && ts != NULL
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_space () == MATCH_YES)
+ {
- if (gfc_match ("elemental% ") == MATCH_YES)
- {
- if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- goto error;
+ seen_type = true;
+ found_prefix = true;
+ }
- goto loop;
+ if (gfc_match ("elemental% ") == MATCH_YES)
+ {
+ if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("pure% ") == MATCH_YES)
+ {
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("recursive% ") == MATCH_YES)
+ {
+ if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ /* IMPURE is a somewhat special case, as it needs not set an actual
+ attribute but rather only prevents ELEMENTAL routines from being
+ automatically PURE. */
+ if (gfc_match ("impure% ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: IMPURE procedure at %C")
+ == FAILURE)
+ goto error;
+
+ seen_impure = true;
+ found_prefix = true;
+ }
}
+ while (found_prefix);
- if (gfc_match ("pure% ") == MATCH_YES)
+ /* IMPURE and PURE must not both appear, of course. */
+ if (seen_impure && current_attr.pure)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- goto error;
-
- goto loop;
+ gfc_error ("PURE and IMPURE must not appear both at %C");
+ goto error;
}
- if (gfc_match ("recursive% ") == MATCH_YES)
+ /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
+ if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
- if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
goto error;
-
- goto loop;
}
/* At this point, the next item is not a prefix. */
return MATCH_ERROR;
sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
sym->ts.interface->ts = current_ts;
+ sym->ts.interface->attr.flavor = FL_PROCEDURE;
sym->ts.interface->attr.function = 1;
- sym->attr.function = sym->ts.interface->attr.function;
+ sym->attr.function = 1;
sym->attr.if_source = IFSRC_UNKNOWN;
}
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;
- }
-
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
goto cleanup;
c->ts = ts;
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
c->ts.interface->ts = ts;
+ c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
- c->attr.function = c->ts.interface->attr.function;
+ c->attr.function = 1;
c->attr.if_source = IFSRC_UNKNOWN;
}
if (gfc_match (" =>") == MATCH_YES)
{
- 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;
- }
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
{
gfc_free_expr (initializer);
case COMP_MODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
+ case COMP_BLOCK:
m = match_procedure_decl ();
break;
case COMP_INTERFACE:
if (m != MATCH_YES)
return m;
+ if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: "
+ "ENTRY statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
state = gfc_current_state ();
if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
"an IF-THEN block");
break;
case COMP_DO:
+ case COMP_DO_CONCURRENT:
gfc_error ("ENTRY statement at %C cannot appear within "
"a DO block");
break;
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
+ /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
+ the symbol existed before. */
+ sym->declared_at = gfc_current_locus;
+
if (add_hidden_procptr_result (sym) == SUCCESS)
sym = sym->result;
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
- block_name = NULL;
-
- if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
+ switch (state)
{
+ case COMP_ASSOCIATE:
+ case COMP_BLOCK:
+ if (!strncmp (block_name, "block@", strlen("block@")))
+ block_name = NULL;
+ break;
+
+ case COMP_CONTAINS:
+ case COMP_DERIVED_CONTAINS:
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
? NULL : gfc_state_stack->previous->sym->name;
+ break;
+
+ default:
+ break;
}
switch (state)
eos_ok = 0;
break;
+ case COMP_ASSOCIATE:
+ *st = ST_END_ASSOCIATE;
+ target = " associate";
+ eos_ok = 0;
+ break;
+
case COMP_BLOCK:
*st = ST_END_BLOCK;
target = " block";
break;
case COMP_DO:
+ case COMP_DO_CONCURRENT:
*st = ST_ENDDO;
target = " do";
eos_ok = 0;
break;
+ case COMP_CRITICAL:
+ *st = ST_END_CRITICAL;
+ target = " critical";
+ eos_ok = 0;
+ break;
+
case COMP_SELECT:
case COMP_SELECT_TYPE:
*st = ST_END_SELECT;
if (gfc_match_eos () == MATCH_YES)
{
- if (!eos_ok)
+ if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
+ "instead of %s statement at %L",
+ gfc_ascii_statement (*st), &old_loc) == FAILURE)
+ goto cleanup;
+ }
+ else if (!eos_ok)
{
/* We would have required END [something]. */
gfc_error ("%s statement expected at %L",
{
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
- && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
+ && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+ && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
return MATCH_YES;
if (!block_name)
if (find_special (name, &sym, false))
return MATCH_ERROR;
+ if (check_function_name (name) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */
if (current_attr.dimension
+ || current_attr.codimension
|| current_attr.allocatable
|| current_attr.pointer
|| current_attr.target)
{
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, !current_attr.codimension,
+ !current_attr.dimension
+ && !current_attr.pointer
+ && !current_attr.target);
if (m == MATCH_ERROR)
goto cleanup;
goto cleanup;
}
+ if (current_attr.codimension && m == MATCH_NO)
+ {
+ gfc_error ("Missing array specification at %L in CODIMENSION "
+ "statement", &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
if ((current_attr.allocatable || current_attr.pointer)
&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
{
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
- to the first component, or '$data' field. */
- if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
+ to the first component, or '_data' field. */
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
{
- gfc_component *comp;
- comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
- if (comp == NULL || gfc_copy_attr (&comp->attr, ¤t_attr,
- &var_locus) == FAILURE)
+ if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr, &var_locus)
+ == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
- sym->attr.class_ok = (sym->attr.class_ok
- || current_attr.allocatable
- || current_attr.pointer);
}
else
{
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ if (current_attr.dimension == 0 && current_attr.codimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
+
+ if (sym->ts.type == BT_CLASS
+ && gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
{
cray_pointer_decl (void)
{
match m;
- gfc_array_spec *as;
+ gfc_array_spec *as = NULL;
gfc_symbol *cptr; /* Pointer symbol. */
gfc_symbol *cpte; /* Pointee symbol. */
locus var_locus;
}
/* Check for an optional array spec. */
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, true, false);
if (m == MATCH_ERROR)
{
gfc_free_array_spec (as);
match
+gfc_match_codimension (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.codimension = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_contiguous (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.contiguous = 1;
+
+ return attr_decl ();
+}
+
+
+match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
case INTERFACE_INTRINSIC_OP:
if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
{
+ gfc_intrinsic_op other_op;
+
gfc_current_ns->operator_access[op] =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
+ /* Handle the case if there is another op with the same
+ function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
+ other_op = gfc_equivalent_op (op);
+
+ if (other_op != INTRINSIC_NONE)
+ gfc_current_ns->operator_access[other_op] =
+ (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
}
else
{
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
for(;;)
{
/* VOLATILE is special because it can be added to host-associated
- symbols locally. */
+ symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
+ /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
+ for variable in a BLOCK which is defined outside of the BLOCK. */
+ if (sym->ns != gfc_current_ns && sym->attr.codimension)
+ {
+ gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+ "%C, which is use-/host-associated", sym->name);
+ return MATCH_ERROR;
+ }
if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
}
+match
+gfc_match_asynchronous (void)
+{
+ gfc_symbol *sym;
+ match m;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+ {
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ goto syntax;
+
+ for(;;)
+ {
+ /* ASYNCHRONOUS is special because it can be added to host-associated
+ symbols locally. */
+ m = gfc_match_symbol (&sym, 1);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+ goto next_item;
+
+ case MATCH_NO:
+ break;
+
+ case MATCH_ERROR:
+ return MATCH_ERROR;
+ }
+
+ 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 ASYNCHRONOUS statement at %C");
+ return MATCH_ERROR;
+}
+
+
/* Match a module procedure statement. Note that we have to modify
symbols in the parent's namespace because the current one was there
to receive symbols that are in an interface's formal argument list. */
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
+ locus old_locus;
gfc_namespace *module_ns;
gfc_interface *old_interface_head, *interface;
end up with a syntax error and need to recover. */
old_interface_head = gfc_current_interface_head ();
+ /* Check if the F2008 optional double colon appears. */
+ gfc_gobble_whitespace ();
+ old_locus = gfc_current_locus;
+ if (gfc_match ("::") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in "
+ "MODULE PROCEDURE statement at %L", &old_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+ else
+ gfc_current_locus = old_locus;
+
for (;;)
{
- locus old_locus = gfc_current_locus;
bool last = false;
+ old_locus = gfc_current_locus;
m = gfc_match_name (name);
if (m == MATCH_NO)
current namespace. */
if (gfc_match_eos () == MATCH_YES)
last = true;
+
if (!last && gfc_match_char (',') != MATCH_YES)
goto syntax;
while (interface != old_interface_head)
{
gfc_interface *i = interface->next;
- gfc_free (interface);
+ free (interface);
interface = i;
}
}
-/* Assign a hash value for a derived type. The algorithm is that of
- SDBM. The hashed string is '[module_name #] derived_name'. */
-static unsigned int
-hash_value (gfc_symbol *sym)
-{
- unsigned int hash = 0;
- const char *c;
- int i, len;
-
- /* Hash of the module or procedure name. */
- if (sym->module != NULL)
- c = sym->module;
- else if (sym->ns && sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- c = sym->ns->proc_name->name;
- else
- c = NULL;
-
- if (c)
- {
- len = strlen (c);
- for (i = 0; i < len; i++, c++)
- hash = (hash << 6) + (hash << 16) - hash + (*c);
-
- /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */
- hash = (hash << 6) + (hash << 16) - hash + '#';
- }
-
- /* Hash of the derived type name. */
- len = strlen (sym->name);
- c = sym->name;
- for (i = 0; i < len; i++, c++)
- hash = (hash << 6) + (hash << 16) - hash + (*c);
-
- /* Return the hash but take the modulus for the sake of module read,
- even though this slightly increases the chance of collision. */
- return (hash % 100000000);
-}
-
-
/* Match the beginning of a derived type declaration. If a type name
was the result of a function, then it is possible to have a symbol
already to be known as a derived type yet have no components. */
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
- sym->attr.extension = attr.extension;
extended->refs++;
gfc_set_sym_referenced (extended);
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
+
+ /* Set extension level. */
+ if (extended->attr.extension == 255)
+ {
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ extended->name, &extended->declared_at);
+ return MATCH_ERROR;
+ }
+ sym->attr.extension = extended->attr.extension + 1;
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
st->n.sym = sym;
}
- if (!sym->vindex)
- /* Set the vindex for this type. */
- sym->vindex = hash_value (sym);
+ if (!sym->hash_value)
+ /* Set the hash for the compound name for this type. */
+ sym->hash_value = gfc_hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;
/* Cray Pointees can be declared as:
- pointer (ipt, a (n,m,...,*))
- By default, this is treated as an AS_ASSUMED_SIZE array. We'll
- cheat and set a constant bound of 1 for the last dimension, if this
- is the case. Since there is no bounds-checking for Cray Pointees,
- this will be okay. */
+ pointer (ipt, a (n,m,...,*)) */
match
gfc_mod_pointee_as (gfc_array_spec *as)
{
as->cray_pointee = true; /* This will be useful to know later. */
if (as->type == AS_ASSUMED_SIZE)
- {
- as->type = AS_EXPLICIT;
- as->upper[as->rank - 1] = gfc_int_expr (1);
- as->cp_was_assumed = true;
- }
+ as->cp_was_assumed = true;
else if (as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Cray Pointee at %C cannot be assumed shape array");
enum_initializer (gfc_expr *last_initializer, locus where)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = gfc_c_int_kind;
- result->where = where;
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
mpz_init (result->value.integer);
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
+ if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
if (initializer == NULL || initializer->ts.type != BT_INTEGER)
{
- gfc_error("ENUMERATOR %L not initialized with integer expression",
- &var_locus);
+ gfc_error ("ENUMERATOR %L not initialized with integer expression",
+ &var_locus);
m = MATCH_ERROR;
- gfc_free_enum_history ();
goto cleanup;
}
{
m = enumerator_decl ();
if (m == MATCH_ERROR)
- goto cleanup;
+ {
+ gfc_free_enum_history ();
+ goto cleanup;
+ }
if (m == MATCH_NO)
break;
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char target_buf[GFC_MAX_SYMBOL_LEN + 1];
- char* target = NULL;
- gfc_typebound_proc* tb;
+ char* target = NULL, *ifc = NULL;
+ gfc_typebound_proc tb;
bool seen_colons;
bool seen_attrs;
match m;
gfc_symtree* stree;
gfc_namespace* ns;
gfc_symbol* block;
+ int num;
/* Check current state. */
gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
return MATCH_ERROR;
}
- target = target_buf;
+ ifc = target_buf;
}
/* Construct the data structure. */
- tb = gfc_get_typebound_proc ();
- tb->where = gfc_current_locus;
- tb->is_generic = 0;
+ memset (&tb, 0, sizeof (tb));
+ tb.where = gfc_current_locus;
/* Match binding attributes. */
- m = match_binding_attributes (tb, false, false);
+ m = match_binding_attributes (&tb, false, false);
if (m == MATCH_ERROR)
return m;
seen_attrs = (m == MATCH_YES);
- /* Check that attribute DEFERRED is given iff an interface is specified, which
- means target != NULL. */
- if (tb->deferred && !target)
+ /* Check that attribute DEFERRED is given if an interface is specified. */
+ if (tb.deferred && !ifc)
{
gfc_error ("Interface must be specified for DEFERRED binding at %C");
return MATCH_ERROR;
}
- if (target && !tb->deferred)
+ if (ifc && !tb.deferred)
{
gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
return MATCH_ERROR;
return MATCH_ERROR;
}
- /* Match the binding name. */
- m = gfc_match_name (name);
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Expected binding name at %C");
- return MATCH_ERROR;
- }
-
- /* Try to match the '=> target', if it's there. */
- m = gfc_match (" =>");
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_YES)
+ /* Match the binding names. */
+ for(num=1;;num++)
{
- if (tb->deferred)
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
{
- gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ gfc_error ("Expected binding name at %C");
return MATCH_ERROR;
}
- if (!seen_colons)
- {
- gfc_error ("'::' needed in PROCEDURE binding with explicit target"
- " at %C");
- return MATCH_ERROR;
- }
+ if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+ " at %C") == FAILURE)
+ return MATCH_ERROR;
- m = gfc_match_name (target_buf);
+ /* Try to match the '=> target', if it's there. */
+ target = ifc;
+ m = gfc_match (" =>");
if (m == MATCH_ERROR)
return m;
- if (m == MATCH_NO)
+ if (m == MATCH_YES)
{
- gfc_error ("Expected binding target after '=>' at %C");
- return MATCH_ERROR;
+ if (tb.deferred)
+ {
+ gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!seen_colons)
+ {
+ gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
}
- target = target_buf;
- }
- /* Now we should have the end. */
- m = gfc_match_eos ();
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Junk after PROCEDURE declaration at %C");
- return MATCH_ERROR;
- }
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
- /* If no target was found, it has the same name as the binding. */
- if (!target)
- target = name;
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
- /* Get the namespace to insert the symbols into. */
- ns = block->f2k_derived;
- gcc_assert (ns);
+ /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
+ if (tb.deferred && !block->attr.abstract)
+ {
+ gfc_error ("Type '%s' containing DEFERRED binding at %C "
+ "is not ABSTRACT", block->name);
+ return MATCH_ERROR;
+ }
- /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
- if (tb->deferred && !block->attr.abstract)
- {
- gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
- block->name);
- return MATCH_ERROR;
- }
+ /* See if we already have a binding with this name in the symtree which
+ would be an error. If a GENERIC already targetted this binding, it may
+ be already there but then typebound is still NULL. */
+ stree = gfc_find_symtree (ns->tb_sym_root, name);
+ if (stree && stree->n.tb)
+ {
+ gfc_error ("There is already a procedure with binding name '%s' for "
+ "the derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
- /* See if we already have a binding with this name in the symtree which would
- be an error. If a GENERIC already targetted this binding, it may be
- already there but then typebound is still NULL. */
- stree = gfc_find_symtree (ns->tb_sym_root, name);
- if (stree && stree->n.tb)
- {
- gfc_error ("There's already a procedure with binding name '%s' for the"
- " derived type '%s' at %C", name, block->name);
- return MATCH_ERROR;
- }
+ /* Insert it and set attributes. */
- /* Insert it and set attributes. */
+ if (!stree)
+ {
+ stree = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (stree);
+ }
+ stree->n.tb = gfc_get_typebound_proc (&tb);
- if (!stree)
- {
- stree = gfc_new_symtree (&ns->tb_sym_root, name);
- gcc_assert (stree);
+ if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
+ false))
+ return MATCH_ERROR;
+ gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
+
+ if (gfc_match_eos () == MATCH_YES)
+ return MATCH_YES;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
}
- stree->n.tb = tb;
-
- if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
- return MATCH_ERROR;
- gfc_set_sym_referenced (tb->u.specific->n.sym);
- return MATCH_YES;
+syntax:
+ gfc_error ("Syntax error in PROCEDURE statement at %C");
+ return MATCH_ERROR;
}
ns = block->f2k_derived;
gcc_assert (block && ns);
+ memset (&tbattr, 0, sizeof (tbattr));
+ tbattr.where = gfc_current_locus;
+
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true, false);
if (m == MATCH_ERROR)
}
else
{
- tb = gfc_get_typebound_proc ();
+ tb = gfc_get_typebound_proc (NULL);
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
bool first, last;
gfc_symbol* block;
+ if (gfc_current_form == FORM_FREE)
+ {
+ char c = gfc_peek_ascii_char ();
+ if (!gfc_is_whitespace (c) && c != ':')
+ return MATCH_NO;
+ }
+
if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
+ if (gfc_current_form == FORM_FIXED)
+ return MATCH_NO;
+
gfc_error ("FINAL declaration at %C must be inside a derived type "
"CONTAINS section");
return MATCH_ERROR;
OSDN Git Service
