/* Declaration statement matcher
- Copyright (C) 2002-2015 Free Software Foundation, Inc.
+ Copyright (C) 2002-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "options.h"
+#include "tree.h"
#include "gfortran.h"
+#include "stringpool.h"
#include "match.h"
#include "parse.h"
-#include "options.h"
#include "constructor.h"
-#include "alias.h"
-#include "tree.h"
-#include "stringpool.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
static symbol_attribute current_attr;
static gfc_array_spec *current_as;
static int colon_seen;
+static int attr_seen;
/* The current binding label (if any). */
static const char* curr_binding_label;
bool gfc_matching_function;
+/* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
+int directive_unroll = -1;
+
+/* If a kind expression of a component of a parameterized derived type is
+ parameterized, temporarily store the expression here. */
+static gfc_expr *saved_kind_expr = NULL;
+
+/* Used to store the parameter list arising in a PDT declaration and
+ in the typespec of a PDT variable or component. */
+static gfc_actual_arglist *decl_type_param_list;
+static gfc_actual_arglist *type_param_spec_list;
/********************* DATA statement subroutines *********************/
if (sym == NULL
|| (sym->attr.flavor != FL_PARAMETER
- && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
+ && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
{
gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
name);
+ *result = NULL;
return MATCH_ERROR;
}
- else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+ else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
return gfc_match_structure_constructor (dt_sym, result);
/* Check to see if the value is an initialization array expression. */
gfc_data *new_data;
match m;
+ /* Before parsing the rest of a DATA statement, check F2008:c1206. */
+ if ((gfc_current_state () == COMP_FUNCTION
+ || gfc_current_state () == COMP_SUBROUTINE)
+ && gfc_state_stack->previous->state == COMP_INTERFACE)
+ {
+ gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
+ return MATCH_ERROR;
+ }
+
set_in_match_data (true);
for (;;)
/************************ Declaration statements *********************/
+/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
+ list). The difference here is the expression is a list of constants
+ and is surrounded by '/'.
+ The typespec ts must match the typespec of the variable which the
+ clist is initializing.
+ The arrayspec tells whether this should match a list of constants
+ corresponding to array elements or a scalar (as == NULL). */
+
+static match
+match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
+{
+ gfc_constructor_base array_head = NULL;
+ gfc_expr *expr = NULL;
+ match m;
+ locus where;
+ mpz_t repeat, cons_size, as_size;
+ bool scalar;
+ int cmp;
+
+ gcc_assert (ts);
+
+ mpz_init_set_ui (repeat, 0);
+ scalar = !as || !as->rank;
+
+ /* We have already matched '/' - now look for a constant list, as with
+ top_val_list from decl.c, but append the result to an array. */
+ if (gfc_match ("/") == MATCH_YES)
+ {
+ gfc_error ("Empty old style initializer list at %C");
+ goto cleanup;
+ }
+
+ where = gfc_current_locus;
+ for (;;)
+ {
+ m = match_data_constant (&expr);
+ if (m != MATCH_YES)
+ expr = NULL; /* match_data_constant may set expr to garbage */
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ /* Found r in repeat spec r*c; look for the constant to repeat. */
+ if ( gfc_match_char ('*') == MATCH_YES)
+ {
+ if (scalar)
+ {
+ gfc_error ("Repeat spec invalid in scalar initializer at %C");
+ goto cleanup;
+ }
+ if (expr->ts.type != BT_INTEGER)
+ {
+ gfc_error ("Repeat spec must be an integer at %C");
+ goto cleanup;
+ }
+ mpz_set (repeat, expr->value.integer);
+ gfc_free_expr (expr);
+ expr = NULL;
+
+ m = match_data_constant (&expr);
+ if (m == MATCH_NO)
+ gfc_error ("Expected data constant after repeat spec at %C");
+ if (m != MATCH_YES)
+ goto cleanup;
+ }
+ /* No repeat spec, we matched the data constant itself. */
+ else
+ mpz_set_ui (repeat, 1);
+
+ if (!scalar)
+ {
+ /* Add the constant initializer as many times as repeated. */
+ for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
+ {
+ /* Make sure types of elements match */
+ if(ts && !gfc_compare_types (&expr->ts, ts)
+ && !gfc_convert_type (expr, ts, 1))
+ goto cleanup;
+
+ gfc_constructor_append_expr (&array_head,
+ gfc_copy_expr (expr), &gfc_current_locus);
+ }
+
+ gfc_free_expr (expr);
+ expr = NULL;
+ }
+
+ /* For scalar initializers quit after one element. */
+ else
+ {
+ if(gfc_match_char ('/') != MATCH_YES)
+ {
+ gfc_error ("End of scalar initializer expected at %C");
+ goto cleanup;
+ }
+ break;
+ }
+
+ if (gfc_match_char ('/') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') == MATCH_NO)
+ goto syntax;
+ }
+
+ /* Set up expr as an array constructor. */
+ if (!scalar)
+ {
+ expr = gfc_get_array_expr (ts->type, ts->kind, &where);
+ expr->ts = *ts;
+ expr->value.constructor = array_head;
+
+ expr->rank = as->rank;
+ expr->shape = gfc_get_shape (expr->rank);
+
+ /* Validate sizes. We built expr ourselves, so cons_size will be
+ constant (we fail above for non-constant expressions).
+ We still need to verify that the array-spec has constant size. */
+ cmp = 0;
+ gcc_assert (gfc_array_size (expr, &cons_size));
+ if (!spec_size (as, &as_size))
+ {
+ gfc_error ("Expected constant array-spec in initializer list at %L",
+ as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
+ cmp = -1;
+ }
+ else
+ {
+ /* Make sure the specs are of the same size. */
+ cmp = mpz_cmp (cons_size, as_size);
+ if (cmp < 0)
+ gfc_error ("Not enough elements in array initializer at %C");
+ else if (cmp > 0)
+ gfc_error ("Too many elements in array initializer at %C");
+ mpz_clear (as_size);
+ }
+ mpz_clear (cons_size);
+ if (cmp)
+ goto cleanup;
+ }
+
+ /* Make sure scalar types match. */
+ else if (!gfc_compare_types (&expr->ts, ts)
+ && !gfc_convert_type (expr, ts, 1))
+ goto cleanup;
+
+ if (expr->ts.u.cl)
+ expr->ts.u.cl->length_from_typespec = 1;
+
+ *result = expr;
+ mpz_clear (repeat);
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in old style initializer list at %C");
+
+cleanup:
+ if (expr)
+ expr->value.constructor = NULL;
+ gfc_free_expr (expr);
+ gfc_constructor_free (array_head);
+ mpz_clear (repeat);
+ return MATCH_ERROR;
+}
+
+
/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
static bool
goto syntax;
else if ((*expr)->expr_type == EXPR_VARIABLE)
{
+ bool t;
gfc_expr *e;
e = gfc_copy_expr (*expr);
&& e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
goto syntax;
- gfc_reduce_init_expr (e);
+ t = gfc_reduce_init_expr (e);
+
+ if (!t && e->ts.type == BT_UNKNOWN
+ && e->symtree->n.sym->attr.untyped == 1
+ && (flag_implicit_none
+ || e->symtree->n.sym->ns->seen_implicit_none == 1
+ || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
+ {
+ gfc_free_expr (e);
+ goto syntax;
+ }
if ((e->ref && e->ref->type == REF_ARRAY
- && e->ref->u.ar.type != AR_ELEMENT)
+ && e->ref->u.ar.type != AR_ELEMENT)
|| (!e->ref && e->expr_type == EXPR_ARRAY))
{
gfc_free_expr (e);
gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
st->n.sym = *result;
st = gfc_get_unique_symtree (gfc_current_ns);
+ sym->refs++;
st->n.sym = sym;
}
}
{
/* Create a partially populated interface symbol to carry the
characteristics of the procedure and the result. */
- sym->ts.interface = gfc_new_symbol (name, sym->ns);
- gfc_add_type (sym->ts.interface, &(sym->ts),
+ sym->tlink = gfc_new_symbol (name, sym->ns);
+ gfc_add_type (sym->tlink, &(sym->ts),
&gfc_current_locus);
- gfc_copy_attr (&sym->ts.interface->attr, &sym->attr, NULL);
+ gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
if (sym->attr.dimension)
- sym->ts.interface->as = gfc_copy_array_spec (sym->as);
+ sym->tlink->as = gfc_copy_array_spec (sym->as);
/* Ideally, at this point, a copy would be made of the formal
arguments and their namespace. However, this does not appear
if (sym->result && sym->result != sym)
{
- sym->ts.interface->result = sym->result;
+ sym->tlink->result = sym->result;
sym->result = NULL;
}
else if (sym->result)
{
- sym->ts.interface->result = sym->ts.interface;
+ sym->tlink->result = sym->tlink;
}
}
else if (sym && !sym->gfc_new
/* 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
+ this is handled using gsymbols to register unique, globally
accessible names. */
if (sym->attr.flavor != 0
&& sym->attr.proc != 0
else if (sym->attr.optional == 1
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs "
"at %L with OPTIONAL attribute in "
- "procedure %qs which is BIND(C)",
- sym->name, &(sym->declared_at),
+ "procedure %qs which is BIND(C)",
+ sym->name, &(sym->declared_at),
sym->ns->proc_name->name))
retval = false;
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
&& !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array %qs "
"at %L as dummy argument to the BIND(C) "
- "procedure '%s' at %L", sym->name,
- &(sym->declared_at),
- sym->ns->proc_name->name,
+ "procedure %qs at %L", sym->name,
+ &(sym->declared_at),
+ sym->ns->proc_name->name,
&(sym->ns->proc_name->declared_at)))
retval = false;
}
{
symbol_attribute attr;
gfc_symbol *sym;
+ int upper;
+ gfc_symtree *st;
- if (gfc_get_symbol (name, NULL, &sym))
+ /* Symbols in a submodule are host associated from the parent module or
+ submodules. Therefore, they can be overridden by declarations in the
+ submodule scope. Deal with this by attaching the existing symbol to
+ a new symtree and recycling the old symtree with a new symbol... */
+ st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
+ && st->n.sym != NULL
+ && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
+ {
+ gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
+ s->n.sym = st->n.sym;
+ sym = gfc_new_symbol (name, gfc_current_ns);
+
+
+ st->n.sym = sym;
+ sym->refs++;
+ gfc_set_sym_referenced (sym);
+ }
+ /* ...Otherwise generate a new symtree and new symbol. */
+ else if (gfc_get_symbol (name, NULL, &sym))
return false;
+ /* Check if the name has already been defined as a type. The
+ first letter of the symtree will be in upper case then. Of
+ course, this is only necessary if the upper case letter is
+ actually different. */
+
+ upper = TOUPPER(name[0]);
+ if (upper != name[0])
+ {
+ char u_name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symtree *st;
+
+ gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
+ strcpy (u_name, name);
+ u_name[0] = upper;
+
+ st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
+
+ /* STRUCTURE types can alias symbol names */
+ if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
+ {
+ gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
+ &st->n.sym->declared_at);
+ return false;
+ }
+ }
+
/* Start updating the symbol table. Add basic type attribute if present. */
if (current_ts.type != BT_UNKNOWN
&& (sym->attr.implicit_type == 0
{
/* 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,
+ if (!set_binding_label (&sym->binding_label, sym->name,
num_idents_on_line))
return false;
}
sym->attr.implied_index = 0;
+ /* Use the parameter expressions for a parameterized derived type. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
+ sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
if (sym->ts.type == BT_CLASS)
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
gfc_char_t *s;
int slen;
- gcc_assert (expr->expr_type == EXPR_CONSTANT);
- gcc_assert (expr->ts.type == BT_CHARACTER);
+ if (expr->ts.type != BT_CHARACTER)
+ return;
+
+ if (expr->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
+ return;
+ }
slen = expr->value.character.length;
if (len != slen)
/* 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
+ if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& !sym->attr.proc_pointer
&& !gfc_check_assign_symbol (sym, NULL, init))
}
else if (init->expr_type == EXPR_ARRAY)
{
- clen = mpz_get_si (init->ts.u.cl->length->value.integer);
+ if (init->ts.u.cl)
+ {
+ const gfc_expr *length = init->ts.u.cl->length;
+ if (length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Cannot initialize parameter array "
+ "at %L "
+ "with variable length elements",
+ &sym->declared_at);
+ return false;
+ }
+ clen = mpz_get_si (length->value.integer);
+ }
+ else if (init->value.constructor)
+ {
+ gfc_constructor *c;
+ c = gfc_constructor_first (init->value.constructor);
+ clen = c->expr->value.character.length;
+ }
+ else
+ gcc_unreachable ();
sym->ts.u.cl->length
= gfc_get_int_expr (gfc_default_integer_kind,
NULL, clen);
for (dim = 0; dim < sym->as->rank; ++dim)
{
int k;
- gfc_expr* lower;
- gfc_expr* e;
+ gfc_expr *e, *lower;
lower = sym->as->lower[dim];
- if (lower->expr_type != EXPR_CONSTANT)
+
+ /* If the lower bound is an array element from another
+ parameterized array, then it is marked with EXPR_VARIABLE and
+ is an initialization expression. Try to reduce it. */
+ if (lower->expr_type == EXPR_VARIABLE)
+ gfc_reduce_init_expr (lower);
+
+ if (lower->expr_type == EXPR_CONSTANT)
+ {
+ /* 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;
+ }
+ else
{
gfc_error ("Non-constant lower bound in implied-shape"
" declaration at %L", &lower->where);
return false;
}
-
- /* 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;
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)
+ if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
{
sym->ts.is_iso_c |= init->ts.is_iso_c;
sym->ts.is_c_interop |= init->ts.is_c_interop;
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
+ gfc_state_data *s;
gfc_component *c;
- bool t = true;
/* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
&& current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
- gfc_error ("Component at %C must have the POINTER attribute");
+ if (current_attr.allocatable
+ && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
+ "must have the POINTER attribute"))
+ {
+ return false;
+ }
+ else if (current_attr.allocatable == 0)
+ {
+ gfc_error ("Component at %C must have the POINTER attribute");
+ return false;
+ }
+ }
+
+ /* F03:C437. */
+ if (current_ts.type == BT_CLASS
+ && !(current_attr.pointer || current_attr.allocatable))
+ {
+ gfc_error ("Component %qs with CLASS at %C must be allocatable "
+ "or pointer", name);
return false;
}
}
}
+ /* If we are in a nested union/map definition, gfc_add_component will not
+ properly find repeated components because:
+ (i) gfc_add_component does a flat search, where components of unions
+ and maps are implicity chained so nested components may conflict.
+ (ii) Unions and maps are not linked as components of their parent
+ structures until after they are parsed.
+ For (i) we use gfc_find_component which searches recursively, and for (ii)
+ we search each block directly from the parse stack until we find the top
+ level structure. */
+
+ s = gfc_state_stack;
+ if (s->state == COMP_UNION || s->state == COMP_MAP)
+ {
+ while (s->state == COMP_UNION || gfc_comp_struct (s->state))
+ {
+ c = gfc_find_component (s->sym, name, true, true, NULL);
+ if (c != NULL)
+ {
+ gfc_error_now ("Component %qs at %C already declared at %L",
+ name, &c->loc);
+ return false;
+ }
+ /* Break after we've searched the entire chain. */
+ if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
+ break;
+ s = s->previous;
+ }
+ }
+
if (!gfc_add_component (gfc_current_block(), name, &c))
return false;
c->ts = current_ts;
if (c->ts.type == BT_CHARACTER)
c->ts.u.cl = cl;
+
+ if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
+ && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
+ && saved_kind_expr != NULL)
+ c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
c->attr = current_attr;
c->initializer = *init;
}
*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);
- }
- }
- }
- }
+ gfc_apply_init (&c->ts, &c->attr, c->initializer);
/* Check array components. */
if (!c->attr.dimension)
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
- t = false;
+ return false;
}
}
else if (c->attr.allocatable)
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
- t = false;
+ return false;
}
}
else
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
- t = false;
+ return false;
}
}
scalar:
if (c->ts.type == BT_CLASS)
- {
- bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+ return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
- if (t)
- t = t2;
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_symbol *sym;
+ gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
+ 0, &sym);
+ if (sym == NULL)
+ {
+ gfc_error ("Type parameter %qs at %C has no corresponding entry "
+ "in the type parameter name list at %L",
+ c->name, &gfc_current_block ()->declared_at);
+ return false;
+ }
+ sym->ts = c->ts;
+ sym->attr.pdt_kind = c->attr.pdt_kind;
+ sym->attr.pdt_len = c->attr.pdt_len;
+ if (c->initializer)
+ sym->value = gfc_copy_expr (c->initializer);
+ sym->attr.flavor = FL_VARIABLE;
}
- return t;
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
+ && decl_type_param_list)
+ c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
+
+ return true;
}
{
match m;
- if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
+ if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
variable_decl (int elem)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ static unsigned int fill_id = 0;
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
/* 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 we are parsing a structure with legacy support, we allow the symbol
+ name to be '%FILL' which gives it an anonymous (inaccessible) name. */
+ m = MATCH_NO;
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () == '%')
+ {
+ gfc_next_ascii_char ();
+ m = gfc_match ("fill");
+ }
+
if (m != MATCH_YES)
- goto cleanup;
+ {
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ goto cleanup;
+ }
+
+ else
+ {
+ m = MATCH_ERROR;
+ if (gfc_current_state () != COMP_STRUCTURE)
+ {
+ if (flag_dec_structure)
+ gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
+ else
+ gfc_error ("%qs at %C is a DEC extension, enable with "
+ "%<-fdec-structure%>", "%FILL");
+ goto cleanup;
+ }
+
+ if (attr_seen)
+ {
+ gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
+ goto cleanup;
+ }
+
+ /* %FILL components are given invalid fortran names. */
+ snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
+ m = MATCH_YES;
+ }
var_locus = gfc_current_locus;
as->type = AS_IMPLIED_SHAPE;
if (as->type == AS_IMPLIED_SHAPE
- && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
+ && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
&var_locus))
{
m = MATCH_ERROR;
if (sym != NULL && (sym->attr.dummy || sym->attr.result))
{
m = MATCH_ERROR;
- gfc_error ("'%s' at %C is a redefinition of the declaration "
+ gfc_error ("%qs at %C is a redefinition of the declaration "
"in the corresponding interface for MODULE "
- "PROCEDURE '%s'", sym->name,
+ "PROCEDURE %qs", sym->name,
gfc_current_ns->proc_name->name);
goto cleanup;
}
}
+ /* %FILL components may not have initializers. */
+ if (strncmp (name, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
/* If this symbol has already shown up in a Cray Pointer declaration,
and this is not a component declaration,
then we want to set the type & bail out. */
- if (flag_cray_pointer && gfc_current_state () != COMP_DERIVED)
+ if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
{
gfc_find_symbol (name, gfc_current_ns, 1, &sym);
if (sym != NULL && sym->attr.cray_pointee)
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
+ if (!gfc_comp_struct (gfc_current_state ())
&& !build_sym (name, cl, cl_deferred, &as, &var_locus))
{
m = MATCH_ERROR;
if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C"))
return MATCH_ERROR;
+
+ /* Allow old style initializations for components of STRUCTUREs and MAPs
+ but not components of derived types. */
else if (gfc_current_state () == COMP_DERIVED)
{
gfc_error ("Invalid old style initialization for derived type "
goto cleanup;
}
- return match_old_style_init (name);
+ /* For structure components, read the initializer as a special
+ expression and let the rest of this function apply the initializer
+ as usual. */
+ else if (gfc_comp_struct (gfc_current_state ()))
+ {
+ m = match_clist_expr (&initializer, ¤t_ts, as);
+ if (m == MATCH_NO)
+ gfc_error ("Syntax error in old style initialization of %s at %C",
+ name);
+ if (m != MATCH_YES)
+ goto cleanup;
+ }
+
+ /* Otherwise we treat the old style initialization just like a
+ DATA declaration for the current variable. */
+ else
+ return match_old_style_init (name);
}
/* The double colon must be present in order to have initializers.
}
if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
- && gfc_state_stack->state != COMP_DERIVED)
+ && !gfc_comp_struct (gfc_state_stack->state))
{
gfc_error ("Initialization of variable at %C is not allowed in "
"a PURE procedure");
}
if (current_attr.flavor != FL_PARAMETER
- && gfc_state_stack->state != COMP_DERIVED)
+ && !gfc_comp_struct (gfc_state_stack->state))
gfc_unset_implicit_pure (gfc_current_ns->proc_name);
if (m != MATCH_YES)
}
if (initializer != NULL && current_attr.allocatable
- && gfc_current_state () == COMP_DERIVED)
+ && gfc_comp_struct (gfc_current_state ()))
{
gfc_error ("Initialization of allocatable component at %C is not "
"allowed");
goto cleanup;
}
+ if (gfc_current_state () == COMP_DERIVED
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ gfc_symbol *param;
+ gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
+ 0, ¶m);
+ if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
+ {
+ gfc_error ("The component with KIND or LEN attribute at %C does not "
+ "not appear in the type parameter list at %L",
+ &gfc_current_block ()->declared_at);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
+ {
+ gfc_error ("The component at %C that appears in the type parameter "
+ "list at %L has neither the KIND nor LEN attribute",
+ &gfc_current_block ()->declared_at);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
+ {
+ gfc_error ("The component at %C which is a type parameter must be "
+ "a scalar");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else if (param && initializer)
+ param->value = gfc_copy_expr (initializer);
+ }
+
/* 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)
+ if (!gfc_comp_struct (gfc_current_state ()))
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
&& !current_attr.pointer && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
+
+ /* If we match a nested structure definition we expect to see the
+ * body even if the variable declarations blow up, so we need to keep
+ * the structure declaration around. */
+ if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
+ gfc_commit_symbol (gfc_new_block);
}
m = (t) ? MATCH_YES : MATCH_ERROR;
return MATCH_ERROR;
}
- if (!gfc_notify_std (GFC_STD_GNU,
- "Nonstandard type declaration %s*%d at %C",
+ if (!gfc_notify_std (GFC_STD_GNU,
+ "Nonstandard type declaration %s*%d at %C",
gfc_basic_typename(ts->type), original_kind))
return MATCH_ERROR;
gfc_expr *e;
match m, n;
char c;
- const char *msg;
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
+ saved_kind_expr = NULL;
where = loc = gfc_current_locus;
loc = gfc_current_locus;
kind_expr:
+
n = gfc_match_init_expr (&e);
+ if (gfc_derived_parameter_expr (e))
+ {
+ ts->kind = 0;
+ saved_kind_expr = gfc_copy_expr (e);
+ goto close_brackets;
+ }
+
if (n != MATCH_YES)
{
if (gfc_matching_function)
goto no_match;
}
- msg = gfc_extract_int (e, &ts->kind);
-
- if (msg != NULL)
+ if (gfc_extract_int (e, &ts->kind, 1))
{
- gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
of the named constants from iso_c_binding. */
ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type;
+ if (e->symtree)
+ ts->interop_kind = e->symtree->n.sym;
}
gfc_free_expr (e);
"is %s", gfc_basic_typename (ts->f90_type), &where,
gfc_basic_typename (ts->type));
+close_brackets:
+
gfc_gobble_whitespace ();
if ((c = gfc_next_ascii_char ()) != ')'
&& (ts->type != BT_CHARACTER || c != ','))
locus where;
gfc_expr *e;
match m, n;
- const char *msg;
+ bool fail;
m = MATCH_NO;
e = NULL;
goto no_match;
}
- msg = gfc_extract_int (e, kind);
+ if (gfc_derived_parameter_expr (e))
+ {
+ saved_kind_expr = e;
+ *kind = 0;
+ return MATCH_YES;
+ }
+
+ fail = gfc_extract_int (e, kind, 1);
*is_iso_c = e->ts.is_iso_c;
- if (msg != NULL)
+ if (fail)
{
- gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
}
-/* 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. */
+/* Matches a RECORD declaration. */
-match
-gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
+static match
+match_record_decl (char *name)
{
- 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;
+ locus old_loc;
+ old_loc = gfc_current_locus;
+ match m;
- /* 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;
+ m = gfc_match (" record /");
+ if (m == MATCH_YES)
+ {
+ if (!flag_dec_structure)
+ {
+ gfc_current_locus = old_loc;
+ gfc_error ("RECORD at %C is an extension, enable it with "
+ "-fdec-structure");
+ return MATCH_ERROR;
+ }
+ m = gfc_match (" %n/", name);
+ if (m == MATCH_YES)
+ return MATCH_YES;
+ }
- /* Clear the current binding label, in case one is given. */
- curr_binding_label = NULL;
+ gfc_current_locus = old_loc;
+ if (flag_dec_structure
+ && (gfc_match (" record% ") == MATCH_YES
+ || gfc_match (" record%t") == MATCH_YES))
+ gfc_error ("Structure name expected after RECORD at %C");
+ if (m == MATCH_NO)
+ return MATCH_NO;
- if (gfc_match (" byte") == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
- return MATCH_ERROR;
+ return MATCH_ERROR;
+}
- if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
- {
+
+/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
+ of expressions to substitute into the possibly parameterized expression
+ 'e'. Using a list is inefficient but should not be too bad since the
+ number of type parameters is not likely to be large. */
+static bool
+insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f)
+{
+ gfc_actual_arglist *param;
+ gfc_expr *copy;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
+ {
+ for (param = type_param_spec_list; param; param = param->next)
+ if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+ break;
+
+ if (param)
+ {
+ copy = gfc_copy_expr (param->expr);
+ *e = *copy;
+ free (copy);
+ }
+ }
+
+ return false;
+}
+
+
+bool
+gfc_insert_kind_parameter_exprs (gfc_expr *e)
+{
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
+}
+
+
+bool
+gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
+{
+ gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
+ type_param_spec_list = param_list;
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
+ type_param_spec_list = NULL;
+ type_param_spec_list = old_param_spec_list;
+}
+
+/* Determines the instance of a parameterized derived type to be used by
+ matching determining the values of the kind parameters and using them
+ in the name of the instance. If the instance exists, it is used, otherwise
+ a new derived type is created. */
+match
+gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
+ gfc_actual_arglist **ext_param_list)
+{
+ /* The PDT template symbol. */
+ gfc_symbol *pdt = *sym;
+ /* The symbol for the parameter in the template f2k_namespace. */
+ gfc_symbol *param;
+ /* The hoped for instance of the PDT. */
+ gfc_symbol *instance;
+ /* The list of parameters appearing in the PDT declaration. */
+ gfc_formal_arglist *type_param_name_list;
+ /* Used to store the parameter specification list during recursive calls. */
+ gfc_actual_arglist *old_param_spec_list;
+ /* Pointers to the parameter specification being used. */
+ gfc_actual_arglist *actual_param;
+ gfc_actual_arglist *tail = NULL;
+ /* Used to build up the name of the PDT instance. The prefix uses 4
+ characters and each KIND parameter 2 more. Allow 8 of the latter. */
+ char name[GFC_MAX_SYMBOL_LEN + 21];
+
+ bool name_seen = (param_list == NULL);
+ bool assumed_seen = false;
+ bool deferred_seen = false;
+ bool spec_error = false;
+ int kind_value, i;
+ gfc_expr *kind_expr;
+ gfc_component *c1, *c2;
+ match m;
+
+ type_param_spec_list = NULL;
+
+ type_param_name_list = pdt->formal;
+ actual_param = param_list;
+ sprintf (name, "Pdt%s", pdt->name);
+
+ /* Run through the parameter name list and pick up the actual
+ parameter values or use the default values in the PDT declaration. */
+ for (; type_param_name_list;
+ type_param_name_list = type_param_name_list->next)
+ {
+ if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
+ {
+ if (actual_param->spec_type == SPEC_ASSUMED)
+ spec_error = deferred_seen;
+ else
+ spec_error = assumed_seen;
+
+ if (spec_error)
+ {
+ gfc_error ("The type parameter spec list at %C cannot contain "
+ "both ASSUMED and DEFERRED parameters");
+ goto error_return;
+ }
+ }
+
+ if (actual_param && actual_param->name)
+ name_seen = true;
+ param = type_param_name_list->sym;
+
+ if (!param || !param->name)
+ continue;
+
+ c1 = gfc_find_component (pdt, param->name, false, true, NULL);
+ /* An error should already have been thrown in resolve.c
+ (resolve_fl_derived0). */
+ if (!pdt->attr.use_assoc && !c1)
+ goto error_return;
+
+ kind_expr = NULL;
+ if (!name_seen)
+ {
+ if (!actual_param && !(c1 && c1->initializer))
+ {
+ gfc_error ("The type parameter spec list at %C does not contain "
+ "enough parameter expressions");
+ goto error_return;
+ }
+ else if (!actual_param && c1 && c1->initializer)
+ kind_expr = gfc_copy_expr (c1->initializer);
+ else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ }
+ else
+ {
+ actual_param = param_list;
+ for (;actual_param; actual_param = actual_param->next)
+ if (actual_param->name
+ && strcmp (actual_param->name, param->name) == 0)
+ break;
+ if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ else
+ {
+ if (c1->initializer)
+ kind_expr = gfc_copy_expr (c1->initializer);
+ else if (!(actual_param && param->attr.pdt_len))
+ {
+ gfc_error ("The derived parameter '%qs' at %C does not "
+ "have a default value", param->name);
+ goto error_return;
+ }
+ }
+ }
+
+ /* Store the current parameter expressions in a temporary actual
+ arglist 'list' so that they can be substituted in the corresponding
+ expressions in the PDT instance. */
+ if (type_param_spec_list == NULL)
+ {
+ type_param_spec_list = gfc_get_actual_arglist ();
+ tail = type_param_spec_list;
+ }
+ else
+ {
+ tail->next = gfc_get_actual_arglist ();
+ tail = tail->next;
+ }
+ tail->name = param->name;
+
+ if (kind_expr)
+ {
+ /* Try simplification even for LEN expressions. */
+ gfc_resolve_expr (kind_expr);
+ gfc_simplify_expr (kind_expr, 1);
+ /* Variable expressions seem to default to BT_PROCEDURE.
+ TODO find out why this is and fix it. */
+ if (kind_expr->ts.type != BT_INTEGER
+ && kind_expr->ts.type != BT_PROCEDURE)
+ {
+ gfc_error ("The parameter expression at %C must be of "
+ "INTEGER type and not %s type",
+ gfc_basic_typename (kind_expr->ts.type));
+ goto error_return;
+ }
+
+ tail->expr = gfc_copy_expr (kind_expr);
+ }
+
+ if (actual_param)
+ tail->spec_type = actual_param->spec_type;
+
+ if (!param->attr.pdt_kind)
+ {
+ if (!name_seen && actual_param)
+ actual_param = actual_param->next;
+ if (kind_expr)
+ {
+ gfc_free_expr (kind_expr);
+ kind_expr = NULL;
+ }
+ continue;
+ }
+
+ if (actual_param
+ && (actual_param->spec_type == SPEC_ASSUMED
+ || actual_param->spec_type == SPEC_DEFERRED))
+ {
+ gfc_error ("The KIND parameter '%qs' at %C cannot either be "
+ "ASSUMED or DEFERRED", param->name);
+ goto error_return;
+ }
+
+ if (!kind_expr || !gfc_is_constant_expr (kind_expr))
+ {
+ gfc_error ("The value for the KIND parameter '%qs' at %C does not "
+ "reduce to a constant expression", param->name);
+ goto error_return;
+ }
+
+ gfc_extract_int (kind_expr, &kind_value);
+ sprintf (name + strlen (name), "_%d", kind_value);
+
+ if (!name_seen && actual_param)
+ actual_param = actual_param->next;
+ gfc_free_expr (kind_expr);
+ }
+
+ if (!name_seen && actual_param)
+ {
+ gfc_error ("The type parameter spec list at %C contains too many "
+ "parameter expressions");
+ goto error_return;
+ }
+
+ /* Now we search for the PDT instance 'name'. If it doesn't exist, we
+ build it, using 'pdt' as a template. */
+ if (gfc_get_symbol (name, pdt->ns, &instance))
+ {
+ gfc_error ("Parameterized derived type at %C is ambiguous");
+ goto error_return;
+ }
+
+ m = MATCH_YES;
+
+ if (instance->attr.flavor == FL_DERIVED
+ && instance->attr.pdt_type)
+ {
+ instance->refs++;
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ gfc_commit_symbols ();
+ return m;
+ }
+
+ /* Start building the new instance of the parameterized type. */
+ gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
+ instance->attr.pdt_template = 0;
+ instance->attr.pdt_type = 1;
+ instance->declared_at = gfc_current_locus;
+
+ /* Add the components, replacing the parameters in all expressions
+ with the expressions for their values in 'type_param_spec_list'. */
+ c1 = pdt->components;
+ tail = type_param_spec_list;
+ for (; c1; c1 = c1->next)
+ {
+ gfc_add_component (instance, c1->name, &c2);
+
+ c2->ts = c1->ts;
+ c2->attr = c1->attr;
+
+ /* The order of declaration of the type_specs might not be the
+ same as that of the components. */
+ if (c1->attr.pdt_kind || c1->attr.pdt_len)
+ {
+ for (tail = type_param_spec_list; tail; tail = tail->next)
+ if (strcmp (c1->name, tail->name) == 0)
+ break;
+ }
+
+ /* Deal with type extension by recursively calling this function
+ to obtain the instance of the extended type. */
+ if (gfc_current_state () != COMP_DERIVED
+ && c1 == pdt->components
+ && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
+ && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
+ {
+ gfc_formal_arglist *f;
+
+ old_param_spec_list = type_param_spec_list;
+
+ /* Obtain a spec list appropriate to the extended type..*/
+ actual_param = gfc_copy_actual_arglist (type_param_spec_list);
+ type_param_spec_list = actual_param;
+ for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+ actual_param = actual_param->next;
+ if (actual_param)
+ {
+ gfc_free_actual_arglist (actual_param->next);
+ actual_param->next = NULL;
+ }
+
+ /* Now obtain the PDT instance for the extended type. */
+ c2->param_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
+ NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->ts.u.derived->refs++;
+ gfc_set_sym_referenced (c2->ts.u.derived);
+
+ /* Set extension level. */
+ if (c2->ts.u.derived->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 %qs at %L",
+ c2->ts.u.derived->name,
+ &c2->ts.u.derived->declared_at);
+ goto error_return;
+ }
+ instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
+
+ continue;
+ }
+
+ /* Set the component kind using the parameterized expression. */
+ if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
+ && c1->kind_expr != NULL)
+ {
+ gfc_expr *e = gfc_copy_expr (c1->kind_expr);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_extract_int (e, &c2->ts.kind);
+ gfc_free_expr (e);
+ if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
+ {
+ gfc_error ("Kind %d not supported for type %s at %C",
+ c2->ts.kind, gfc_basic_typename (c2->ts.type));
+ goto error_return;
+ }
+ }
+
+ /* Similarly, set the string length if parameterized. */
+ if (c1->ts.type == BT_CHARACTER
+ && c1->ts.u.cl->length
+ && gfc_derived_parameter_expr (c1->ts.u.cl->length))
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->ts.u.cl->length);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ c2->ts.u.cl->length = e;
+ c2->attr.pdt_string = 1;
+ }
+
+ /* Set up either the KIND/LEN initializer, if constant,
+ or the parameterized expression. Use the template
+ initializer if one is not already set in this instance. */
+ if (c2->attr.pdt_kind || c2->attr.pdt_len)
+ {
+ if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
+ c2->initializer = gfc_copy_expr (tail->expr);
+ else if (tail && tail->expr)
+ {
+ c2->param_list = gfc_get_actual_arglist ();
+ c2->param_list->name = tail->name;
+ c2->param_list->expr = gfc_copy_expr (tail->expr);
+ c2->param_list->next = NULL;
+ }
+
+ if (!c2->initializer && c1->initializer)
+ c2->initializer = gfc_copy_expr (c1->initializer);
+ }
+
+ /* Copy the array spec. */
+ c2->as = gfc_copy_array_spec (c1->as);
+ if (c1->ts.type == BT_CLASS)
+ CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
+
+ /* Determine if an array spec is parameterized. If so, substitute
+ in the parameter expressions for the bounds and set the pdt_array
+ attribute. Notice that this attribute must be unconditionally set
+ if this is an array of parameterized character length. */
+ if (c1->as && c1->as->type == AS_EXPLICIT)
+ {
+ bool pdt_array = false;
+
+ /* Are the bounds of the array parameterized? */
+ for (i = 0; i < c1->as->rank; i++)
+ {
+ if (gfc_derived_parameter_expr (c1->as->lower[i]))
+ pdt_array = true;
+ if (gfc_derived_parameter_expr (c1->as->upper[i]))
+ pdt_array = true;
+ }
+
+ /* If they are, free the expressions for the bounds and
+ replace them with the template expressions with substitute
+ values. */
+ for (i = 0; pdt_array && i < c1->as->rank; i++)
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->as->lower[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->lower[i]);
+ c2->as->lower[i] = e;
+ e = gfc_copy_expr (c1->as->upper[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->upper[i]);
+ c2->as->upper[i] = e;
+ }
+ c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+ }
+
+ /* Recurse into this function for PDT components. */
+ if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
+ {
+ gfc_actual_arglist *params;
+ /* The component in the template has a list of specification
+ expressions derived from its declaration. */
+ params = gfc_copy_actual_arglist (c1->param_list);
+ actual_param = params;
+ /* Substitute the template parameters with the expressions
+ from the specification list. */
+ for (;actual_param; actual_param = actual_param->next)
+ gfc_insert_parameter_exprs (actual_param->expr,
+ type_param_spec_list);
+
+ /* Now obtain the PDT instance for the component. */
+ old_param_spec_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->param_list = params;
+ if (!(c2->attr.pointer || c2->attr.allocatable))
+ c2->initializer = gfc_default_initializer (&c2->ts);
+
+ if (c2->attr.allocatable)
+ instance->attr.alloc_comp = 1;
+ }
+ }
+
+ gfc_commit_symbol (instance);
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ return m;
+
+error_return:
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+}
+
+
+/* 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;
+
+ decl_type_param_list = NULL;
+
+ /* 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"))
+ 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;
{
if ((m = gfc_match ("*)")) != MATCH_YES)
return m;
- if (gfc_current_state () == COMP_DERIVED)
+ if (gfc_comp_struct (gfc_current_state ()))
{
gfc_error ("Assumed type at %C is not allowed for components");
return MATCH_ERROR;
}
if (matched_type)
+ {
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
m = gfc_match_char (')');
+ }
+
+ if (m != MATCH_YES)
+ m = match_record_decl (name);
+
+ if (matched_type || m == MATCH_YES)
+ {
+ ts->type = BT_DERIVED;
+ /* We accept record/s/ or type(s) where s is a structure, but we
+ * don't need all the extra derived-type stuff for structures. */
+ if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
+ {
+ gfc_error ("Type name %qs at %C is ambiguous", name);
+ return MATCH_ERROR;
+ }
+
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
+ if (sym && sym->attr.flavor == FL_STRUCT)
+ {
+ ts->u.derived = sym;
+ return MATCH_YES;
+ }
+ /* Actually a derived type. */
+ }
- if (m == MATCH_YES)
- ts->type = BT_DERIVED;
else
{
+ /* Match nested STRUCTURE declarations; only valid within another
+ structure declaration. */
+ if (flag_dec_structure
+ && (gfc_current_state () == COMP_STRUCTURE
+ || gfc_current_state () == COMP_MAP))
+ {
+ m = gfc_match (" structure");
+ if (m == MATCH_YES)
+ {
+ m = gfc_match_structure_decl ();
+ if (m == MATCH_YES)
+ {
+ /* gfc_new_block is updated by match_structure_decl. */
+ ts->type = BT_DERIVED;
+ ts->u.derived = gfc_new_block;
+ return MATCH_YES;
+ }
+ }
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ }
+
/* Match CLASS declarations. */
m = gfc_match (" class ( * )");
if (m == MATCH_ERROR)
/* 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,
+ if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
&gfc_current_locus))
- return MATCH_ERROR;
- }
+ 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 = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe;
upe->refs++;
}
return m;
}
- m = gfc_match (" class ( %n )", name);
+ m = gfc_match (" class (");
+
+ if (m == MATCH_YES)
+ m = gfc_match ("%n", name);
+ else
+ return m;
+
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
+
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ return m;
}
/* Defer association of the derived type until the end of the
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]);
+ dt_name = gfc_dt_upper_string (name);
sym = NULL;
dt_sym = NULL;
if (ts->kind != -1)
}
if (sym->generic && !dt_sym)
dt_sym = gfc_find_dt_in_generic (sym);
+
+ /* Host associated PDTs can get confused with their constructors
+ because they ar instantiated in the template's namespace. */
+ if (!dt_sym)
+ {
+ if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
+ {
+ gfc_error ("Type name %qs at %C is ambiguous", name);
+ return MATCH_ERROR;
+ }
+ if (dt_sym && !dt_sym->attr.pdt_type)
+ dt_sym = NULL;
+ }
}
else if (ts->kind == -1)
{
return MATCH_NO;
}
- if ((sym->attr.flavor != FL_UNKNOWN
+ if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
return MATCH_ERROR;
}
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
gfc_save_symbol_data (sym);
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
&& !gfc_add_function (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
+ if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
+ && dt_sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
+ }
+
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);
+ dt_sym->name = gfc_get_string ("%s", sym->name);
head = sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
gfc_set_sym_referenced (dt_sym);
- if (dt_sym->attr.flavor != FL_DERIVED
+ if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
&& !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
return MATCH_ERROR;
if (c == '(')
{
(void) gfc_next_ascii_char ();
- if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C"))
+ if (!gfc_notify_std (GFC_STD_F2018, "IMPORT NONE with spec list at %C"))
return MATCH_ERROR;
gfc_gobble_whitespace ();
letter of the name capitalized; the symtree with the all
lower-case name contains the associated generic function. */
st = gfc_new_symtree (&gfc_current_ns->sym_root,
- gfc_get_string ("%c%s",
- (char) TOUPPER ((unsigned char) name[0]),
- &name[1]));
+ gfc_dt_upper_string (name));
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
+ DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
- DECL_NONE, GFC_DECL_END /* Sentinel */
+ DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
current_as = NULL;
colon_seen = 0;
+ attr_seen = 0;
/* See if we get all of the keywords up to the final double colon. */
for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
d = DECL_ASYNCHRONOUS;
}
break;
+
+ case 'u':
+ if (match_string_p ("tomatic"))
+ {
+ /* Matched "automatic". */
+ d = DECL_AUTOMATIC;
+ }
+ break;
}
break;
d = DECL_CODIMENSION;
break;
}
+ /* FALLTHRU */
case 'n':
if (match_string_p ("tiguous"))
{
}
break;
+ case 'k':
+ if (match_string_p ("kind"))
+ d = DECL_KIND;
+ break;
+
+ case 'l':
+ if (match_string_p ("len"))
+ d = DECL_LEN;
+ break;
+
case 'o':
if (match_string_p ("optional"))
d = DECL_OPTIONAL;
break;
case 's':
- if (match_string_p ("save"))
- d = DECL_SAVE;
+ gfc_next_ascii_char ();
+ switch (gfc_next_ascii_char ())
+ {
+ case 'a':
+ if (match_string_p ("ve"))
+ {
+ /* Matched "save". */
+ d = DECL_SAVE;
+ }
+ break;
+
+ case 't':
+ if (match_string_p ("atic"))
+ {
+ /* Matched "static". */
+ d = DECL_STATIC;
+ }
+ break;
+ }
break;
case 't':
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
+ case DECL_KIND:
+ attr = "KIND";
+ break;
+ case DECL_LEN:
+ attr = "LEN";
+ break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
case DECL_SAVE:
attr = "SAVE";
break;
+ case DECL_STATIC:
+ attr = "STATIC";
+ break;
+ case DECL_AUTOMATIC:
+ attr = "AUTOMATIC";
+ break;
case DECL_TARGET:
attr = "TARGET";
break;
{
if (seen[d] == 0)
continue;
+ else
+ attr_seen = 1;
+
+ if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
+ && !flag_dec_static)
+ {
+ gfc_error ("%s at %L is a DEC extension, enable with "
+ "%<-fdec-static%>",
+ d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ /* Allow SAVE with STATIC, but don't complain. */
+ if (d == DECL_STATIC && seen[DECL_SAVE])
+ continue;
if (gfc_current_state () == COMP_DERIVED
&& d != DECL_DIMENSION && d != DECL_CODIMENSION
goto cleanup;
}
}
+ else if (d == DECL_KIND)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "KIND "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+ else if (d == DECL_LEN)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "LEN "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
else
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
&& gfc_state_stack->previous->state == COMP_MODULE)
{
if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
- "at %L in a TYPE definition", attr,
+ "at %L in a TYPE definition", attr,
&seen_at[d]))
{
m = MATCH_ERROR;
}
}
+ if (gfc_current_state () != COMP_DERIVED
+ && (d == DECL_KIND || d == DECL_LEN))
+ {
+ gfc_error ("Attribute at %L is not allowed outside a TYPE "
+ "definition", &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
switch (d)
{
case DECL_ALLOCATABLE:
t = gfc_add_optional (¤t_attr, &seen_at[d]);
break;
+ case DECL_KIND:
+ t = gfc_add_kind (¤t_attr, &seen_at[d]);
+ break;
+
+ case DECL_LEN:
+ t = gfc_add_len (¤t_attr, &seen_at[d]);
+ break;
+
case DECL_PARAMETER:
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
break;
case DECL_PROTECTED:
- if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ if (gfc_current_state () != COMP_MODULE
+ || (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
{
gfc_error ("PROTECTED at %C only allowed in specification "
"part of a module");
&seen_at[d]);
break;
+ case DECL_STATIC:
case DECL_SAVE:
t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
+ case DECL_AUTOMATIC:
+ t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_TARGET:
t = gfc_add_target (¤t_attr, &seen_at[d]);
break;
gfc_current_locus = start;
gfc_free_array_spec (current_as);
current_as = NULL;
+ attr_seen = 0;
return m;
}
bool retval = true;
/* destLabel, common name, typespec (which may have binding label). */
- if (!set_binding_label (&com_block->binding_label, com_block->name,
+ if (!set_binding_label (&com_block->binding_label, com_block->name,
num_idents))
return false;
match m;
int elem;
+ type_param_spec_list = NULL;
+ decl_type_param_list = NULL;
+
num_idents_on_line = 0;
m = gfc_match_decl_type_spec (¤t_ts, 0);
return m;
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
- && gfc_current_state () != COMP_DERIVED)
+ && !gfc_comp_struct (gfc_current_state ()))
{
sym = gfc_use_derived (current_ts.u.derived);
&& !current_ts.u.derived->attr.zero_comp)
{
- if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
+ if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
+ goto ok;
+
+ if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
+ && current_ts.u.derived == gfc_current_block ())
goto ok;
gfc_find_symbol (current_ts.u.derived->name,
current_ts.u.derived->ns, 1, &sym);
/* Any symbol that we find had better be a type definition
- which has its components defined. */
- if (sym != NULL && sym->attr.flavor == FL_DERIVED
+ which has its components defined, or be a structure definition
+ actively being parsed. */
+ if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
&& (current_ts.u.derived->components != NULL
- || current_ts.u.derived->attr.zero_comp))
+ || current_ts.u.derived->attr.zero_comp
+ || current_ts.u.derived == gfc_new_block))
goto ok;
gfc_error ("Derived type at %C has not been previously defined "
}
if (!gfc_error_flag_test ())
- gfc_error ("Syntax error in data declaration at %C");
+ {
+ /* An anonymous structure declaration is unambiguous; if we matched one
+ according to gfc_match_structure_decl, we need to return MATCH_YES
+ here to avoid confusing the remaining matchers, even if there was an
+ error during variable_decl. We must flush any such errors. Note this
+ causes the parser to gracefully continue parsing the remaining input
+ as a structure body, which likely follows. */
+ if (current_ts.type == BT_DERIVED && current_ts.u.derived
+ && gfc_fl_struct (current_ts.u.derived->attr.flavor))
+ {
+ gfc_error_now ("Syntax error in anonymous structure declaration"
+ " at %C");
+ /* Skip the bad variable_decl and line up for the start of the
+ structure body. */
+ gfc_error_recovery ();
+ m = MATCH_YES;
+ goto cleanup;
+ }
+
+ gfc_error ("Syntax error in data declaration at %C");
+ }
+
m = MATCH_ERROR;
gfc_free_data_all (gfc_current_ns);
cleanup:
+ if (saved_kind_expr)
+ gfc_free_expr (saved_kind_expr);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ if (decl_type_param_list)
+ gfc_free_actual_arglist (decl_type_param_list);
+ saved_kind_expr = NULL;
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
{
found_prefix = false;
+ /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
+ corresponding attribute seems natural and distinguishes these
+ procedures from procedure types of PROC_MODULE, which these are
+ as well. */
+ if (gfc_match ("module% ") == MATCH_YES)
+ {
+ if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
+ goto error;
+
+ current_attr.module_procedure = 1;
+ found_prefix = true;
+ }
+
if (!seen_type && ts != NULL
&& gfc_match_decl_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
/* At this point, the next item is not a prefix. */
gcc_assert (gfc_matching_prefix);
- /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
- Since this is a prefix like PURE, ELEMENTAL, etc., having a
- corresponding attribute seems natural and distinguishes these
- procedures from procedure types of PROC_MODULE, which these are
- as well. */
- if ((gfc_current_state () == COMP_INTERFACE
- || gfc_current_state () == COMP_CONTAINS)
- && gfc_match ("module% ") == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
- goto error;
- else
- current_attr.module_procedure = 1;
- }
-
gfc_matching_prefix = false;
return MATCH_YES;
static bool
copy_prefix (symbol_attribute *dest, locus *where)
{
- if (current_attr.pure && !gfc_add_pure (dest, where))
- return false;
+ if (dest->module_procedure)
+ {
+ if (current_attr.elemental)
+ dest->elemental = 1;
+
+ if (current_attr.pure)
+ dest->pure = 1;
+
+ if (current_attr.recursive)
+ dest->recursive = 1;
+
+ /* Module procedures are unusual in that the 'dest' is copied from
+ the interface declaration. However, this is an oportunity to
+ check that the submodule declaration is compliant with the
+ interface. */
+ if (dest->elemental && !current_attr.elemental)
+ {
+ gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
+ "missing at %L", where);
+ return false;
+ }
+
+ if (dest->pure && !current_attr.pure)
+ {
+ gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
+ "missing at %L", where);
+ return false;
+ }
+
+ if (dest->recursive && !current_attr.recursive)
+ {
+ gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
+ "missing at %L", where);
+ return false;
+ }
+
+ return true;
+ }
if (current_attr.elemental && !gfc_add_elemental (dest, where))
return false;
+ if (current_attr.pure && !gfc_add_pure (dest, where))
+ return false;
+
if (current_attr.recursive && !gfc_add_recursive (dest, where))
return false;
}
-/* Match a formal argument list. */
+/* Match a formal argument list or, if typeparam is true, a
+ type_param_name_list. */
match
-gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
+gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
+ int null_flag, bool typeparam)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
if (gfc_match_char ('*') == MATCH_YES)
{
sym = NULL;
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
- "at %C"))
+ if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
+ "Alternate-return argument at %C"))
{
m = MATCH_ERROR;
goto cleanup;
}
+ else if (typeparam)
+ gfc_error_now ("A parameter name is required at %C");
}
else
{
m = gfc_match_name (name);
if (m != MATCH_YES)
- goto cleanup;
+ {
+ if(typeparam)
+ gfc_error_now ("A parameter name is required at %C");
+ goto cleanup;
+ }
- if (gfc_get_symbol (name, NULL, &sym))
+ if (!typeparam && gfc_get_symbol (name, NULL, &sym))
+ goto cleanup;
+ else if (typeparam
+ && gfc_get_symbol (name, progname->f2k_derived, &sym))
goto cleanup;
}
/* The name of a program unit can be in a different namespace,
so check for it explicitly. After the statement is accepted,
the name is checked for especially in gfc_get_symbol(). */
- if (gfc_new_block != NULL && sym != NULL
+ if (gfc_new_block != NULL && sym != NULL && !typeparam
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
gfc_error ("Name %qs at %C is the name of the procedure",
m = gfc_match_char (',');
if (m != MATCH_YES)
{
- gfc_error ("Unexpected junk in formal argument list at %C");
+ if (typeparam)
+ gfc_error_now ("Expected parameter list in type declaration "
+ "at %C");
+ else
+ gfc_error ("Unexpected junk in formal argument list at %C");
goto cleanup;
}
}
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
- gfc_error ("Duplicate symbol %qs in formal argument list "
- "at %C", p->sym->name);
+ if (typeparam)
+ gfc_error_now ("Duplicate name %qs in parameter "
+ "list at %C", p->sym->name);
+ else
+ gfc_error ("Duplicate symbol %qs in formal argument "
+ "list at %C", p->sym->name);
m = MATCH_ERROR;
goto cleanup;
goto cleanup;
}
- if (formal)
+ /* gfc_error_now used in following and return with MATCH_YES because
+ doing otherwise results in a cascade of extraneous errors and in
+ some cases an ICE in symbol.c(gfc_release_symbol). */
+ if (progname->attr.module_procedure && progname->attr.host_assoc)
{
+ bool arg_count_mismatch = false;
+
+ if (!formal && head)
+ arg_count_mismatch = true;
+
+ /* Abbreviated module procedure declaration is not meant to have any
+ formal arguments! */
+ if (!progname->abr_modproc_decl && formal && !head)
+ arg_count_mismatch = true;
+
for (p = formal, q = head; p && q; p = p->next, q = q->next)
{
if ((p->next != NULL && q->next == NULL)
|| (p->next == NULL && q->next != NULL))
- gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
- "formal arguments at %C");
+ arg_count_mismatch = true;
else if ((p->sym == NULL && q->sym == NULL)
|| strcmp (p->sym->name, q->sym->name) == 0)
continue;
"argument names (%s/%s) at %C",
p->sym->name, q->sym->name);
}
+
+ if (arg_count_mismatch)
+ gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
+ "formal arguments at %C");
}
return MATCH_YES;
gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
st2->n.sym = stree->n.sym;
+ stree->n.sym->refs++;
}
sym->result = stree->n.sym;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
invalid per F08:C1216 (cf. resolve_procedure_interface). */
- while ((*proc_if)->ts.interface)
+ while ((*proc_if)->ts.interface
+ && *proc_if != (*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
if ((*proc_if)->attr.flavor == FL_UNKNOWN
&& (*proc_if)->ts.type == BT_UNKNOWN
- && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
+ && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
(*proc_if)->name, NULL))
return MATCH_ERROR;
}
if (!gfc_add_function (&sym->attr, sym->name, NULL))
goto cleanup;
- if (!gfc_missing_attr (&sym->attr, NULL)
- || !copy_prefix (&sym->attr, &sym->declared_at))
+ if (!gfc_missing_attr (&sym->attr, NULL))
goto cleanup;
+ if (!copy_prefix (&sym->attr, &sym->declared_at))
+ {
+ if(!sym->attr.module_procedure)
+ goto cleanup;
+ else
+ gfc_error_check ();
+ }
+
/* Delay matching the function characteristics until after the
specification block by signalling kind=-1. */
sym->declared_at = old_loc;
gfc_error ("ENTRY statement at %C cannot appear within "
"an INTERFACE");
break;
+ case COMP_STRUCTURE:
+ gfc_error ("ENTRY statement at %C cannot appear within "
+ "a STRUCTURE block");
+ break;
case COMP_DERIVED:
gfc_error ("ENTRY statement at %C cannot appear within "
"a DERIVED TYPE block");
return MATCH_ERROR;
}
+ if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
+ && gfc_state_stack->previous->state == COMP_INTERFACE)
+ {
+ gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
+ return MATCH_ERROR;
+ }
+
module_procedure = gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor
gfc_error ("Missing required parentheses before BIND(C) at %C");
return MATCH_ERROR;
}
- if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
+ if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
&(entry->declared_at), 1))
return MATCH_ERROR;
}
gfc_error ("Missing required parentheses before BIND(C) at %C");
return MATCH_ERROR;
}
- if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
+ if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
&(sym->declared_at), 1))
return MATCH_ERROR;
}
}
if (!copy_prefix (&sym->attr, &sym->declared_at))
- return MATCH_ERROR;
+ {
+ if(!sym->attr.module_procedure)
+ return MATCH_ERROR;
+ else
+ gfc_error_check ();
+ }
/* Warn if it has the same name as an intrinsic. */
do_warn_intrinsic_shadow (sym, false);
match m;
gfc_namespace *parent_ns, *ns, *prev_ns;
gfc_namespace **nsp;
- bool abreviated_modproc_decl;
+ bool abreviated_modproc_decl = false;
+ bool got_matching_end = false;
old_loc = gfc_current_locus;
if (gfc_match ("end") != MATCH_YES)
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
? NULL : gfc_state_stack->previous->sym->name;
+ abreviated_modproc_decl = gfc_state_stack->previous->sym
+ && gfc_state_stack->previous->sym->abr_modproc_decl;
break;
default:
break;
}
- abreviated_modproc_decl
- = gfc_current_block ()
- && gfc_current_block ()->abr_modproc_decl;
+ if (!abreviated_modproc_decl)
+ abreviated_modproc_decl = gfc_current_block ()
+ && gfc_current_block ()->abr_modproc_decl;
switch (state)
{
eos_ok = 0;
break;
+ case COMP_MAP:
+ *st = ST_END_MAP;
+ target = " map";
+ eos_ok = 0;
+ break;
+
+ case COMP_UNION:
+ *st = ST_END_UNION;
+ target = " union";
+ eos_ok = 0;
+ break;
+
+ case COMP_STRUCTURE:
+ *st = ST_END_STRUCTURE;
+ target = " structure";
+ eos_ok = 0;
+ break;
+
case COMP_DERIVED:
case COMP_DERIVED_CONTAINS:
*st = ST_END_TYPE;
if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
- "instead of %s statement at %L",
+ "instead of %s statement at %L",
abreviated_modproc_decl ? "END PROCEDURE"
: gfc_ascii_statement(*st), &old_loc))
goto cleanup;
? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
goto cleanup;
}
+ else
+ got_matching_end = true;
old_loc = gfc_current_locus;
/* If we're at the end, make sure a block name wasn't required. */
/* If we are missing an END BLOCK, we created a half-ready namespace.
Remove it from the parent namespace's sibling list. */
- while (state == COMP_BLOCK)
+ while (state == COMP_BLOCK && !got_matching_end)
{
parent_ns = gfc_current_ns->parent;
prev_ns = ns;
ns = ns->sibling;
}
-
+
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = parent_ns;
gfc_state_stack = gfc_state_stack->previous;
if (current_attr.dimension && sym->value)
{
gfc_error ("Dimensions specified for %s at %L after its "
- "initialisation", sym->name, &var_locus);
+ "initialization", sym->name, &var_locus);
m = MATCH_ERROR;
goto cleanup;
}
goto syntax;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
+
if (gfc_get_symbol (name, NULL, &sym))
goto done;
- if (!gfc_add_access (&sym->attr,
- (st == ST_PUBLIC)
- ? ACCESS_PUBLIC : ACCESS_PRIVATE,
+ if (type == INTERFACE_DTIO
+ && gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
+ && sym->attr.flavor == FL_UNKNOWN)
+ sym->attr.flavor = FL_PROCEDURE;
+
+ if (!gfc_add_access (&sym->attr,
+ (st == ST_PUBLIC)
+ ? ACCESS_PUBLIC : ACCESS_PRIVATE,
sym->name, NULL))
return MATCH_ERROR;
if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
- && !gfc_add_access (&dt_sym->attr,
- (st == ST_PUBLIC)
- ? ACCESS_PUBLIC : ACCESS_PRIVATE,
+ && !gfc_add_access (&dt_sym->attr,
+ (st == ST_PUBLIC)
+ ? ACCESS_PUBLIC : ACCESS_PRIVATE,
sym->name, NULL))
return MATCH_ERROR;
match
gfc_match_parameter (void)
{
+ const char *term = " )%t";
+ match m;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ {
+ /* With legacy PARAMETER statements, don't expect a terminating ')'. */
+ if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
+ return MATCH_NO;
+ term = " %t";
+ }
+
+ for (;;)
+ {
+ m = do_parm ();
+ if (m != MATCH_YES)
+ break;
+
+ if (gfc_match (term) == MATCH_YES)
+ break;
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Unexpected characters in PARAMETER statement at %C");
+ m = MATCH_ERROR;
+ break;
+ }
+ }
+
+ return m;
+}
+
+
+match
+gfc_match_automatic (void)
+{
+ gfc_symbol *sym;
+ match m;
+ bool seen_symbol = false;
+
+ if (!flag_dec_static)
+ {
+ gfc_error ("%s at %C is a DEC extension, enable with "
+ "%<-fdec-static%>",
+ "AUTOMATIC"
+ );
+ return MATCH_ERROR;
+ }
+
+ gfc_match (" ::");
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_NO:
+ break;
+
+ case MATCH_ERROR:
+ return MATCH_ERROR;
+
+ case MATCH_YES:
+ if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
+ return MATCH_ERROR;
+ seen_symbol = true;
+ break;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (!seen_symbol)
+ {
+ gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in AUTOMATIC statement at %C");
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_static (void)
+{
+ gfc_symbol *sym;
match m;
+ bool seen_symbol = false;
- if (gfc_match_char ('(') == MATCH_NO)
- return MATCH_NO;
+ if (!flag_dec_static)
+ {
+ gfc_error ("%s at %C is a DEC extension, enable with "
+ "%<-fdec-static%>",
+ "STATIC");
+ return MATCH_ERROR;
+ }
+
+ gfc_match (" ::");
for (;;)
{
- m = do_parm ();
- if (m != MATCH_YES)
- break;
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_NO:
+ break;
+
+ case MATCH_ERROR:
+ return MATCH_ERROR;
- if (gfc_match (" )%t") == MATCH_YES)
+ case MATCH_YES:
+ if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus))
+ return MATCH_ERROR;
+ seen_symbol = true;
break;
+ }
+ if (gfc_match_eos () == MATCH_YES)
+ break;
if (gfc_match_char (',') != MATCH_YES)
- {
- gfc_error ("Unexpected characters in PARAMETER statement at %C");
- m = MATCH_ERROR;
- break;
- }
+ goto syntax;
}
- return m;
+ if (!seen_symbol)
+ {
+ gfc_error ("Expected entity-list in STATIC statement at %C");
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in STATIC statement at %C");
+ return MATCH_ERROR;
}
switch (m)
{
case MATCH_YES:
- if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
&gfc_current_locus))
return MATCH_ERROR;
goto next_item;
if (gfc_current_state () != COMP_CONTAINS
|| !(gfc_state_stack->previous
- && gfc_state_stack->previous->state == COMP_SUBMODULE))
+ && (gfc_state_stack->previous->state == COMP_SUBMODULE
+ || gfc_state_stack->previous->state == COMP_MODULE)))
return MATCH_NO;
m = gfc_match (" module% procedure% %n", name);
/* Make sure that the result field is appropriately filled, even though
the result symbol will be replaced later on. */
- if (sym->ts.interface->attr.function)
+ if (sym->tlink && sym->tlink->attr.function)
{
- if (sym->ts.interface->result
- && sym->ts.interface->result != sym->ts.interface)
- sym->result= sym->ts.interface->result;
+ if (sym->tlink->result
+ && sym->tlink->result != sym->tlink)
+ sym->result= sym->tlink->result;
else
sym->result = sym;
}
}
+/* Common function for type declaration blocks similar to derived types, such
+ as STRUCTURES and MAPs. Unlike derived types, a structure type
+ does NOT have a generic symbol matching the name given by the user.
+ STRUCTUREs can share names with variables and PARAMETERs so we must allow
+ for the creation of an independent symbol.
+ Other parameters are a message to prefix errors with, the name of the new
+ type to be created, and the flavor to add to the resulting symbol. */
+
+static bool
+get_struct_decl (const char *name, sym_flavor fl, locus *decl,
+ gfc_symbol **result)
+{
+ gfc_symbol *sym;
+ locus where;
+
+ gcc_assert (name[0] == (char) TOUPPER (name[0]));
+
+ if (decl)
+ where = *decl;
+ else
+ where = gfc_current_locus;
+
+ if (gfc_get_symbol (name, NULL, &sym))
+ return false;
+
+ if (!sym)
+ {
+ gfc_internal_error ("Failed to create structure type '%s' at %C", name);
+ return false;
+ }
+
+ if (sym->components != NULL || sym->attr.zero_comp)
+ {
+ gfc_error ("Type definition of %qs at %C was already defined at %L",
+ sym->name, &sym->declared_at);
+ return false;
+ }
+
+ sym->declared_at = where;
+
+ if (sym->attr.flavor != fl
+ && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
+ return false;
+
+ if (!sym->hash_value)
+ /* Set the hash for the compound name for this type. */
+ sym->hash_value = gfc_hash_value (sym);
+
+ /* Normally the type is expected to have been completely parsed by the time
+ a field declaration with this type is seen. For unions, maps, and nested
+ structure declarations, we need to indicate that it is okay that we
+ haven't seen any components yet. This will be updated after the structure
+ is fully parsed. */
+ sym->attr.zero_comp = 0;
+
+ /* Structures always act like derived-types with the SEQUENCE attribute */
+ gfc_add_sequence (&sym->attr, sym->name, NULL);
+
+ if (result) *result = sym;
+
+ return true;
+}
+
+
+/* Match the opening of a MAP block. Like a struct within a union in C;
+ behaves identical to STRUCTURE blocks. */
+
+match
+gfc_match_map (void)
+{
+ /* Counter used to give unique internal names to map structures. */
+ static unsigned int gfc_map_id = 0;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ locus old_loc;
+
+ old_loc = gfc_current_locus;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after MAP statement at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ /* Map blocks are anonymous so we make up unique names for the symbol table
+ which are invalid Fortran identifiers. */
+ snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
+
+ if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
+ return MATCH_ERROR;
+
+ gfc_new_block = sym;
+
+ return MATCH_YES;
+}
+
+
+/* Match the opening of a UNION block. */
+
+match
+gfc_match_union (void)
+{
+ /* Counter used to give unique internal names to union types. */
+ static unsigned int gfc_union_id = 0;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ locus old_loc;
+
+ old_loc = gfc_current_locus;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after UNION statement at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ /* Unions are anonymous so we make up unique names for the symbol table
+ which are invalid Fortran identifiers. */
+ snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
+
+ if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
+ return MATCH_ERROR;
+
+ gfc_new_block = sym;
+
+ return MATCH_YES;
+}
+
+
+/* Match the beginning of a STRUCTURE declaration. This is similar to
+ matching the beginning of a derived type declaration with a few
+ twists. The resulting type symbol has no access control or other
+ interesting attributes. */
+
+match
+gfc_match_structure_decl (void)
+{
+ /* Counter used to give unique internal names to anonymous structures. */
+ static unsigned int gfc_structure_id = 0;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ match m;
+ locus where;
+
+ if (!flag_dec_structure)
+ {
+ gfc_error ("%s at %C is a DEC extension, enable with "
+ "%<-fdec-structure%>",
+ "STRUCTURE");
+ return MATCH_ERROR;
+ }
+
+ name[0] = '\0';
+
+ m = gfc_match (" /%n/", name);
+ if (m != MATCH_YES)
+ {
+ /* Non-nested structure declarations require a structure name. */
+ if (!gfc_comp_struct (gfc_current_state ()))
+ {
+ gfc_error ("Structure name expected in non-nested structure "
+ "declaration at %C");
+ return MATCH_ERROR;
+ }
+ /* This is an anonymous structure; make up a unique name for it
+ (upper-case letters never make it to symbol names from the source).
+ The important thing is initializing the type variable
+ and setting gfc_new_symbol, which is immediately used by
+ parse_structure () and variable_decl () to add components of
+ this type. */
+ snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
+ }
+
+ where = gfc_current_locus;
+ /* No field list allowed after non-nested structure declaration. */
+ if (!gfc_comp_struct (gfc_current_state ())
+ && gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after non-nested STRUCTURE statement at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Make sure the name is not the name of an intrinsic type. */
+ if (gfc_is_intrinsic_typename (name))
+ {
+ gfc_error ("Structure name %qs at %C cannot be the same as an"
+ " intrinsic type", name);
+ return MATCH_ERROR;
+ }
+
+ /* Store the actual type symbol for the structure with an upper-case first
+ letter (an invalid Fortran identifier). */
+
+ if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
+ return MATCH_ERROR;
+
+ gfc_new_block = sym;
+ return MATCH_YES;
+}
+
+
+/* This function does some work to determine which matcher should be used to
+ * match a statement beginning with "TYPE". This is used to disambiguate TYPE
+ * as an alias for PRINT from derived type declarations, TYPE IS statements,
+ * and derived type data declarations. */
+
+match
+gfc_match_type (gfc_statement *st)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ match m;
+ locus old_loc;
+
+ /* Requires -fdec. */
+ if (!flag_dec)
+ return MATCH_NO;
+
+ m = gfc_match ("type");
+ if (m != MATCH_YES)
+ return m;
+ /* If we already have an error in the buffer, it is probably from failing to
+ * match a derived type data declaration. Let it happen. */
+ else if (gfc_error_flag_test ())
+ return MATCH_NO;
+
+ old_loc = gfc_current_locus;
+ *st = ST_NONE;
+
+ /* If we see an attribute list before anything else it's definitely a derived
+ * type declaration. */
+ if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
+ {
+ gfc_current_locus = old_loc;
+ *st = ST_DERIVED_DECL;
+ return gfc_match_derived_decl ();
+ }
+
+ /* By now "TYPE" has already been matched. If we do not see a name, this may
+ * be something like "TYPE *" or "TYPE <fmt>". */
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ {
+ /* Let print match if it can, otherwise throw an error from
+ * gfc_match_derived_decl. */
+ gfc_current_locus = old_loc;
+ if (gfc_match_print () == MATCH_YES)
+ {
+ *st = ST_WRITE;
+ return MATCH_YES;
+ }
+ gfc_current_locus = old_loc;
+ *st = ST_DERIVED_DECL;
+ return gfc_match_derived_decl ();
+ }
+
+ /* A derived type declaration requires an EOS. Without it, assume print. */
+ m = gfc_match_eos ();
+ if (m == MATCH_NO)
+ {
+ /* Check manually for TYPE IS (... - this is invalid print syntax. */
+ if (strncmp ("is", name, 3) == 0
+ && gfc_match (" (", name) == MATCH_YES)
+ {
+ gfc_current_locus = old_loc;
+ gcc_assert (gfc_match (" is") == MATCH_YES);
+ *st = ST_TYPE_IS;
+ return gfc_match_type_is ();
+ }
+ gfc_current_locus = old_loc;
+ *st = ST_WRITE;
+ return gfc_match_print ();
+ }
+ else
+ {
+ /* By now we have "TYPE <name> <EOS>". Check first if the name is an
+ * intrinsic typename - if so let gfc_match_derived_decl dump an error.
+ * Otherwise if gfc_match_derived_decl fails it's probably an existing
+ * symbol which can be printed. */
+ gfc_current_locus = old_loc;
+ m = gfc_match_derived_decl ();
+ if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
+ {
+ *st = ST_DERIVED_DECL;
+ return m;
+ }
+ gfc_current_locus = old_loc;
+ *st = ST_WRITE;
+ return gfc_match_print ();
+ }
+
+ return MATCH_NO;
+}
+
+
/* 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. */
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
gfc_interface *intr = NULL, *head;
+ bool parameterized_type = false;
+ bool seen_colons = false;
- if (gfc_current_state () == COMP_DERIVED)
+ if (gfc_comp_struct (gfc_current_state ()))
return MATCH_NO;
name[0] = '\0';
if (parent[0] && !extended)
return MATCH_ERROR;
- if (gfc_match (" ::") != MATCH_YES && seen_attr)
+ m = gfc_match (" ::");
+ if (m == MATCH_YES)
+ {
+ seen_colons = true;
+ }
+ else if (seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
- m = gfc_match (" %n%t", name);
+ m = gfc_match (" %n ", name);
if (m != MATCH_YES)
return m;
+ /* Make sure that we don't identify TYPE IS (...) as a parameterized
+ derived type named 'is'.
+ TODO Expand the check, when 'name' = "is" by matching " (tname) "
+ and checking if this is a(n intrinsic) typename. his picks up
+ misplaced TYPE IS statements such as in select_type_1.f03. */
+ if (gfc_peek_ascii_char () == '(')
+ {
+ if (gfc_current_state () == COMP_SELECT_TYPE
+ || (!seen_colons && !strcmp (name, "is")))
+ return MATCH_NO;
+ parameterized_type = true;
+ }
+
+ m = gfc_match_eos ();
+ if (m != MATCH_YES && !parameterized_type)
+ return m;
+
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
if (!sym)
{
/* Use upper case to save the actual derived-type symbol. */
- gfc_get_symbol (gfc_get_string ("%c%s",
- (char) TOUPPER ((unsigned char) gensym->name[0]),
- &gensym->name[1]), NULL, &sym);
- sym->name = gfc_get_string (gensym->name);
+ gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
+ sym->name = gfc_get_string ("%s", gensym->name);
head = gensym->generic;
intr = gfc_get_interface ();
intr->sym = sym;
return MATCH_ERROR;
else if (sym->attr.access == ACCESS_UNKNOWN
&& gensym->attr.access != ACCESS_UNKNOWN
- && !gfc_add_access (&sym->attr, gensym->attr.access,
+ && !gfc_add_access (&sym->attr, gensym->attr.access,
sym->name, NULL))
return MATCH_ERROR;
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (parameterized_type)
+ {
+ /* Ignore error or mismatches by going to the end of the statement
+ in order to avoid the component declarations causing problems. */
+ m = gfc_match_formal_arglist (sym, 0, 0, true);
+ if (m != MATCH_YES)
+ gfc_error_recovery ();
+ m = gfc_match_eos ();
+ if (m != MATCH_YES)
+ return m;
+ sym->attr.pdt_template = 1;
+ }
+
if (extended && !sym->components)
{
gfc_component *p;
+ gfc_formal_arglist *f, *g, *h;
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
extended->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* Copy the extended type-param-name-list from the extended type,
+ append those of the extension and add the whole lot to the
+ extension. */
+ if (extended->attr.pdt_template)
+ {
+ g = h = NULL;
+ sym->attr.pdt_template = 1;
+ for (f = extended->formal; f; f = f->next)
+ {
+ if (f == extended->formal)
+ {
+ g = gfc_get_formal_arglist ();
+ h = g;
+ }
+ else
+ {
+ g->next = gfc_get_formal_arglist ();
+ g = g->next;
+ }
+ g->sym = f->sym;
+ }
+ g->next = sym->formal;
+ sym->formal = h;
+ }
}
if (!sym->hash_value)
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
- ba->pass_arg = gfc_get_string (arg);
+ ba->pass_arg = gfc_get_string ("%s", arg);
gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
found_passing = true;
false))
return MATCH_ERROR;
gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
+ gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
+ target, &stree->n.tb->u.specific->n.sym->declared_at);
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
switch (op_type)
{
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
gfc_symtree* st;
st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
- if (st)
- {
- tb = st->n.tb;
- gcc_assert (tb);
- }
- else
- tb = NULL;
-
+ tb = st ? st->n.tb : NULL;
break;
}
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_OP:
{
const bool is_op = (op_type == INTERFACE_USER_OP);
- gfc_symtree* st;
-
- st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root,
- name);
+ gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
+ &ns->tb_sym_root, name);
gcc_assert (st);
st->n.tb = tb;
for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->proc_sym == sym)
{
- gfc_error ("%qs at %C is already defined as FINAL procedure!",
+ gfc_error ("%qs at %C is already defined as FINAL procedure",
name);
return MATCH_ERROR;
}
/* Add this symbol to the list of finalizers. */
gcc_assert (block->f2k_derived);
- ++sym->refs;
+ sym->refs++;
f = XCNEW (gfc_finalizer);
f->proc_sym = sym;
f->proc_tree = NULL;
gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
return MATCH_ERROR;
}
+
+
+/* Match a !GCC$ UNROLL statement of the form:
+ !GCC$ UNROLL n
+
+ The parameter n is the number of times we are supposed to unroll.
+
+ When we come here, we have already matched the !GCC$ UNROLL string. */
+match
+gfc_match_gcc_unroll (void)
+{
+ int value;
+
+ if (gfc_match_small_int (&value) == MATCH_YES)
+ {
+ if (value < 0 || value > USHRT_MAX)
+ {
+ gfc_error ("%<GCC unroll%> directive requires a"
+ " non-negative integral constant"
+ " less than or equal to %u at %C",
+ USHRT_MAX
+ );
+ return MATCH_ERROR;
+ }
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ directive_unroll = value == 0 ? 1 : value;
+ return MATCH_YES;
+ }
+ }
+
+ gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
+ return MATCH_ERROR;
+}
projects / thirdparty / gcc.git / blobdiff