/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "match.h"
#include "parse.h"
-
+#include "flags.h"
+#include "constructor.h"
+#include "tree.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
#define gfc_get_data() XCNEW (gfc_data)
+static gfc_try set_binding_label (const char **, const char *, int);
+
+
/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
static int colon_seen;
/* The current binding label (if any). */
-static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+static const char* curr_binding_label;
/* Need to know how many identifiers are on the current data declaration
line in case we're given the BIND(C) attribute with a NAME= specifier. */
static int num_idents_on_line;
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;
}
}
match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym = NULL;
gfc_expr *expr;
match m;
locus old_loc;
if (gfc_find_symbol (name, NULL, 1, &sym))
return MATCH_ERROR;
+ if (sym && sym->attr.generic)
+ dt_sym = gfc_find_dt_in_generic (sym);
+
if (sym == NULL
- || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
+ || (sym->attr.flavor != FL_PARAMETER
+ && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
- else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result, false);
+ else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+ return gfc_match_structure_constructor (dt_sym, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
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;
}
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
goto syntax;
if (e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl
- && e->symtree->n.sym->ts.cl->length->ts.type == BT_UNKNOWN)
+ && e->symtree->n.sym->ts.u.cl
+ && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
goto syntax;
}
}
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 (m == MATCH_YES)
{
- *expr = gfc_int_expr (length);
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
+ "Old-style character length at %C") == FAILURE)
+ return MATCH_ERROR;
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
}
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
- m = char_len_param_value (expr);
+ m = char_len_param_value (expr, deferred);
if (m != MATCH_YES && gfc_matching_function)
{
gfc_undo_symbols ();
(located in another namespace). */
static int
-find_special (const char *name, gfc_symbol **result)
+find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
{
gfc_state_data *s;
+ gfc_symtree *st;
int i;
- i = gfc_get_symbol (name, NULL, result);
+ i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
if (i == 0)
- goto end;
+ {
+ *result = st ? st->n.sym : NULL;
+ goto end;
+ }
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
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.derived->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 "
length of 1. */
if (sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
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. */
}
+
/* 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.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;
with a bind(c) and make sure the binding label is set correctly. */
if (sym->attr.is_bind_c == 1)
{
- if (sym->binding_label[0] == '\0')
+ if (!sym->binding_label)
{
/* Set the binding label and verify that if a NAME= was specified
then only one identifier was in the entity-decl-list. */
- if (set_binding_label (sym->binding_label, sym->name,
+ if (set_binding_label (&sym->binding_label, sym->name,
num_idents_on_line) == FAILURE)
return FAILURE;
}
sym->attr.implied_index = 0;
+ if (sym->ts.type == BT_CLASS)
+ return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+
return SUCCESS;
}
&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;
gfc_expr *init;
init = *initp;
- if (find_special (name, &sym))
+ if (find_special (name, &sym, false))
return FAILURE;
attr = sym->attr;
}
/* 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 (sym->ts.type == BT_CHARACTER && sym->ts.cl)
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
+ && init->ts.type == BT_CHARACTER)
{
/* Update symbol character length according initializer. */
- if (sym->ts.cl->length == NULL)
+ if (gfc_check_assign_symbol (sym, init) == FAILURE)
+ return FAILURE;
+
+ if (sym->ts.u.cl->length == NULL)
{
int clen;
/* If there are multiple CHARACTER variables declared on the
same line, we don't want them to share the same length. */
- sym->ts.cl = gfc_get_charlen ();
- sym->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = sym->ts.cl;
+ sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (sym->attr.flavor == FL_PARAMETER)
{
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.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.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.cl && init->ts.cl->length)
- sym->ts.cl->length =
- gfc_copy_expr (sym->value->ts.cl->length);
+ else if (init->ts.u.cl && init->ts.u.cl->length)
+ sym->ts.u.cl->length =
+ gfc_copy_expr (sym->value->ts.u.cl->length);
}
}
/* Update initializer character length according symbol. */
- else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- int len = mpz_get_si (sym->ts.cl->length->value.integer);
- gfc_constructor * p;
+ int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
+ gfc_constructor *c;
+
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
- init->ts.cl = gfc_get_charlen ();
- init->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = sym->ts.cl;
- init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
+ init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
+
+ for (c = gfc_constructor_first (init->value.constructor);
+ c; c = gfc_constructor_next (c))
+ gfc_set_constant_character_len (len, c->expr, -1);
+ }
+ }
+ }
+
+ /* If sym is implied-shape, set its upper bounds from init. */
+ if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
+ && sym->as->type == AS_IMPLIED_SHAPE)
+ {
+ int dim;
+
+ if (init->rank == 0)
+ {
+ gfc_error ("Can't initialize implied-shape array at %L"
+ " with scalar", &sym->declared_at);
+ return FAILURE;
+ }
+ gcc_assert (sym->as->rank == init->rank);
+
+ /* Shape should be present, we get an initialization expression. */
+ gcc_assert (init->shape);
- for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, -1);
+ 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]);
gfc_array_spec **as)
{
gfc_component *c;
+ gfc_try t = SUCCESS;
- /* If the current symbol is of the same derived type that we're
+ /* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
- if (current_ts.type == BT_DERIVED
- && current_ts.derived == gfc_current_block ()
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
gfc_error ("Component at %C must have the POINTER attribute");
return FAILURE;
c->ts = current_ts;
- c->ts.cl = cl;
+ if (c->ts.type == BT_CHARACTER)
+ c->ts.u.cl = cl;
c->attr = current_attr;
c->initializer = *init;
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
in add_init_expr_to_sym into a separate function. */
- if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.cl
- && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
+ 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.cl && c->ts.cl->length);
- gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT);
- gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER);
+ 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.cl->length->value.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.cl->length->value.integer,
- c->initializer->ts.cl->length->value.integer))
+ 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;
-
- bool first = true;
- int first_len;
+ gfc_constructor *ctor;
+ ctor = gfc_constructor_first (c->initializer->value.constructor);
- has_ts = (c->initializer->ts.cl
- && c->initializer->ts.cl->length_from_typespec);
-
- for (; ctor; ctor = ctor->next)
+ if (ctor)
{
- /* 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! */
- if (first)
+ 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)
{
- gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
- gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
- first_len = ctor->expr->value.character.length;
- first = false;
+ 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);
}
-
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
}
}
}
/* Check array components. */
if (!c->attr.dimension)
- {
- if (c->attr.allocatable)
- {
- gfc_error ("Allocatable component at %C must be an array");
- return FAILURE;
- }
- else
- return SUCCESS;
- }
+ goto scalar;
if (c->attr.pointer)
{
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else if (c->attr.allocatable)
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
- return FAILURE;
+ t = FAILURE;
}
}
- return SUCCESS;
+scalar:
+ if (c->ts.type == BT_CLASS)
+ {
+ bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
+ || (!c->ts.u.derived->components
+ && !c->ts.u.derived->attr.zero_comp);
+ 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;
gfc_symbol *sym;
- locus old_locus;
initializer = NULL;
as = NULL;
cp_as = NULL;
- old_locus = gfc_current_locus;
/* 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
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_get_charlen ();
- cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = cl;
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
cl->length = char_len;
break;
element. Also copy assumed lengths. */
case MATCH_NO:
if (elem > 1
- && (current_ts.cl->length == NULL
- || current_ts.cl->length->expr_type != EXPR_CONSTANT))
+ && (current_ts.u.cl->length == NULL
+ || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
{
- cl = gfc_get_charlen ();
- cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = cl;
- cl->length = gfc_copy_expr (current_ts.cl->length);
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
+ cl->length = gfc_copy_expr (current_ts.u.cl->length);
}
else
- cl = current_ts.cl;
+ cl = current_ts.u.cl;
+
+ cl_deferred = current_ts.deferred;
break;
{
sym->ts.type = current_ts.type;
sym->ts.kind = current_ts.kind;
- sym->ts.cl = cl;
- sym->ts.derived = current_ts.derived;
+ sym->ts.u.cl = cl;
+ sym->ts.u.derived = current_ts.u.derived;
sym->ts.is_c_interop = current_ts.is_c_interop;
sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES;
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.derived->ns != gfc_current_ns)
+ && current_ts.u.derived->ns != gfc_current_ns)
{
gfc_symtree *st;
- st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
- if (!(current_ts.derived->attr.imported
+ st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
+ if (!(current_ts.u.derived->attr.imported
&& st != NULL
- && st->n.sym == current_ts.derived)
+ && gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
&& !gfc_current_ns->has_import_set)
{
- gfc_error ("the type of '%s' at %C has not been declared within the "
+ gfc_error ("The type of '%s' at %C has not been declared within the "
"interface", name);
m = MATCH_ERROR;
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_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");
return MATCH_ERROR;
}
ts->kind /= 2;
+
+ }
+
+ if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+ ts->kind = 8;
+
+ if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
+ {
+ if (ts->kind == 4)
+ {
+ if (gfc_option.flag_real4_kind == 8)
+ ts->kind = 8;
+ if (gfc_option.flag_real4_kind == 10)
+ ts->kind = 10;
+ if (gfc_option.flag_real4_kind == 16)
+ ts->kind = 16;
+ }
+
+ if (ts->kind == 8)
+ {
+ if (gfc_option.flag_real8_kind == 4)
+ ts->kind = 4;
+ if (gfc_option.flag_real8_kind == 10)
+ ts->kind = 10;
+ if (gfc_option.flag_real8_kind == 16)
+ ts->kind = 16;
+ }
}
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
&& !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
|| (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
- gfc_error_now ("C kind type parameter is for type %s but type at %L "
- "is %s", gfc_basic_typename (ts->f90_type), &where,
- gfc_basic_typename (ts->type));
+ gfc_warning_now ("C kind type parameter is for type %s but type at %L "
+ "is %s", gfc_basic_typename (ts->f90_type), &where,
+ gfc_basic_typename (ts->type));
gfc_gobble_whitespace ();
if ((c = gfc_next_ascii_char ()) != ')'
if(m == MATCH_ERROR)
gfc_current_locus = where;
-
+
+ if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+ ts->kind = 8;
+
+ if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
+ {
+ if (ts->kind == 4)
+ {
+ if (gfc_option.flag_real4_kind == 8)
+ ts->kind = 8;
+ if (gfc_option.flag_real4_kind == 10)
+ ts->kind = 10;
+ if (gfc_option.flag_real4_kind == 16)
+ ts->kind = 16;
+ }
+
+ if (ts->kind == 8)
+ {
+ if (gfc_option.flag_real8_kind == 4)
+ ts->kind = 4;
+ if (gfc_option.flag_real8_kind == 10)
+ ts->kind = 10;
+ if (gfc_option.flag_real8_kind == 16)
+ ts->kind = 16;
+ }
+ }
+
/* Return what we know from the test(s). */
return m;
return m;
}
+
/* Match the various kind/length specifications in a CHARACTER
declaration. We don't return MATCH_NO. */
-static match
-match_char_spec (gfc_typespec *ts)
+match
+gfc_match_char_spec (gfc_typespec *ts)
{
int kind, seen_length, is_iso_c;
gfc_charlen *cl;
gfc_expr *len;
match m;
+ bool deferred;
len = NULL;
seen_length = 0;
kind = 0;
is_iso_c = 0;
+ deferred = false;
/* Try the old-style specification first. */
old_char_selector = 0;
- m = match_char_length (&len);
+ 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)
}
/* Do some final massaging of the length values. */
- cl = gfc_get_charlen ();
- cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = cl;
+ 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->cl = cl;
+ 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. */
}
-/* Matches a type specification. If successful, sets the ts structure
- to the matched specification. This is necessary for FUNCTION and
+/* 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
statement correctly. */
match
-gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
+gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
match m;
char c;
- bool seen_deferred_kind;
+ bool seen_deferred_kind, matched_type;
+ const char *dt_name;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
ts->kind = -1;
/* Clear the current binding label, in case one is given. */
- curr_binding_label[0] = '\0';
+ curr_binding_label = NULL;
if (gfc_match (" byte") == MATCH_YES)
{
- if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
== FAILURE)
return MATCH_ERROR;
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 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 (m != MATCH_YES)
- return m;
+ 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;
+ }
- ts->type = BT_DERIVED;
+ m = gfc_match (" class ( %n )", name);
+ if (m != MATCH_YES)
+ return m;
+ ts->type = BT_CLASS;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+ }
/* Defer association of the derived type until the end of the
specification block. However, if the derived type can be
found, add it to the typespec. */
if (gfc_matching_function)
{
- ts->derived = NULL;
+ ts->u.derived = NULL;
if (gfc_current_state () != COMP_INTERFACE
&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
- ts->derived = sym;
+ {
+ sym = gfc_find_dt_in_generic (sym);
+ ts->u.derived = sym;
+ }
return MATCH_YES;
}
/* Search for the name but allow the components to be defined later. If
type = -1, this typespec has been seen in a function declaration but
- the type could not be accessed at that point. */
+ the type could not be accessed at that point. The actual derived type is
+ stored in a symtree with the first letter of the name captialized; the
+ symtree with the all lower-case name contains the associated
+ generic function. */
+ dt_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) name[0]),
+ (const char*)&name[1]);
sym = NULL;
- if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
+ dt_sym = NULL;
+ if (ts->kind != -1)
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
- return MATCH_ERROR;
+ gfc_get_ha_symbol (name, &sym);
+ if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
+ {
+ gfc_error ("Type name '%s' at %C is ambiguous", name);
+ return MATCH_ERROR;
+ }
+ if (sym->generic && !dt_sym)
+ dt_sym = gfc_find_dt_in_generic (sym);
}
else if (ts->kind == -1)
{
int iface = gfc_state_stack->previous->state != COMP_INTERFACE
|| gfc_current_ns->has_import_set;
- if (gfc_find_symbol (name, NULL, iface, &sym))
+ gfc_find_symbol (name, NULL, iface, &sym);
+ if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
+ if (sym && sym->generic && !dt_sym)
+ dt_sym = gfc_find_dt_in_generic (sym);
ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
- if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
+ if ((sym->attr.flavor != FL_UNKNOWN
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
+ || sym->attr.subroutine)
+ {
+ gfc_error ("Type name '%s' at %C conflicts with previously declared "
+ "entity at %L, which has the same name", name,
+ &sym->declared_at);
+ return MATCH_ERROR;
+ }
gfc_set_sym_referenced (sym);
- ts->derived = sym;
+ if (!sym->attr.generic
+ && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
- return MATCH_YES;
+ if (!sym->attr.function
+ && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
-get_kind:
- /* For all types except double, derived and character, look for an
- optional kind specifier. MATCH_NO is actually OK at this point. */
+ if (!dt_sym)
+ {
+ gfc_interface *intr, *head;
+
+ /* Use upper case to save the actual derived-type symbol. */
+ gfc_get_symbol (dt_name, NULL, &dt_sym);
+ dt_sym->name = gfc_get_string (sym->name);
+ head = sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ sym->generic = intr;
+ sym->attr.if_source = IFSRC_DECL;
+ }
+
+ gfc_set_sym_referenced (dt_sym);
+
+ if (dt_sym->attr.flavor != FL_DERIVED
+ && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ ts->u.derived = dt_sym;
+
+ return MATCH_YES;
+
+get_kind:
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "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 = 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 ())
gfc_clear_new_implicit ();
/* A basic type is mandatory here. */
- m = gfc_match_type_spec (&ts, 1);
+ m = gfc_match_decl_type_spec (&ts, 1);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
if ((c == '\n') || (c == ','))
{
/* Check for CHARACTER with no length parameter. */
- if (ts.type == BT_CHARACTER && !ts.cl)
+ if (ts.type == BT_CHARACTER && !ts.u.cl)
{
ts.kind = gfc_default_character_kind;
- ts.cl = gfc_get_charlen ();
- ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = ts.cl;
- ts.cl->length = gfc_int_expr (1);
+ ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
/* Record the Successful match. */
/* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
if (ts.type == BT_CHARACTER)
- m = match_char_spec (&ts);
+ m = gfc_match_char_spec (&ts);
else
{
m = gfc_match_kind_spec (&ts, false);
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))
sym->refs++;
sym->attr.imported = 1;
+ if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
+ {
+ /* The actual derived type is stored in a symtree with the first
+ letter of the name captialized; 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) sym->name[0]),
+ &sym->name[1]));
+ st->n.sym = sym;
+ sym->refs++;
+ sym->attr.imported = 1;
+ }
+
goto next_item;
case MATCH_NO:
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;
locus start, seen_at[NUM_DECL];
int seen[NUM_DECL];
- decl_types d;
+ unsigned int d;
const char *attr;
match m;
gfc_try t;
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:
}
}
+ /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
+ if (gfc_current_state () == COMP_MODULE && !current_attr.save
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ current_attr.save = SAVE_IMPLICIT;
+
colon_seen = 1;
return MATCH_YES;
(J3/04-007, section 15.4.1). If a binding label was given and
there is more than one argument (num_idents), it is an error. */
-gfc_try
-set_binding_label (char *dest_label, const char *sym_name, int num_idents)
+static gfc_try
+set_binding_label (const char **dest_label, const char *sym_name,
+ int num_idents)
{
if (num_idents > 1 && has_name_equals)
{
return FAILURE;
}
- if (curr_binding_label[0] != '\0')
- {
- /* Binding label given; store in temp holder til have sym. */
- strcpy (dest_label, curr_binding_label);
- }
+ if (curr_binding_label)
+ /* Binding label given; store in temp holder til have sym. */
+ *dest_label = curr_binding_label;
else
{
/* No binding label given, and the NAME= specifier did not exist,
which means there was no NAME="". */
if (sym_name != NULL && has_name_equals == 0)
- strcpy (dest_label, sym_name);
+ *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
}
return SUCCESS;
/* 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->derived != NULL)
- return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ if (ts->type == BT_DERIVED && ts->u.derived != NULL)
+ 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)
/* BIND(C) functions can not return a character string. */
if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
- if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
- || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
+ if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
+ || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
/* See if the symbol has been marked as private. If it has, make sure
there is no binding label and warn the user if there is one. */
if (tmp_sym->attr.access == ACCESS_PRIVATE
- && tmp_sym->binding_label[0] != '\0')
+ && tmp_sym->binding_label)
/* Use gfc_warning_now because we won't say that the symbol fails
just because of this. */
gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
/* Set the is_bind_c bit in symbol_attribute. */
gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
- if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
+ if (set_binding_label (&tmp_sym->binding_label, tmp_sym->name,
num_idents) != SUCCESS)
return FAILURE;
gfc_try retval = SUCCESS;
/* destLabel, common name, typespec (which may have binding label). */
- if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
+ if (set_binding_label (&com_block->binding_label, com_block->name,
+ num_idents)
!= SUCCESS)
return FAILURE;
/* This may not be necessary. */
gfc_clear_ts (ts);
/* Clear the temporary binding label holder. */
- curr_binding_label[0] = '\0';
+ curr_binding_label = NULL;
/* Look for the bind(c). */
found_match = gfc_match_bind_c (NULL, true);
num_idents_on_line = 0;
- m = gfc_match_type_spec (¤t_ts, 0);
+ m = gfc_match_decl_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
- if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && gfc_current_state () != COMP_DERIVED)
{
- sym = gfc_use_derived (current_ts.derived);
+ sym = gfc_use_derived (current_ts.u.derived);
if (sym == NULL)
{
goto cleanup;
}
- current_ts.derived = sym;
+ current_ts.u.derived = sym;
}
m = match_attr_spec ();
goto cleanup;
}
- if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL
- && !current_ts.derived->attr.zero_comp)
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && current_ts.u.derived->components == NULL
+ && !current_ts.u.derived->attr.zero_comp)
{
if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
goto ok;
- gfc_find_symbol (current_ts.derived->name,
- current_ts.derived->ns->parent, 1, &sym);
+ gfc_find_symbol (current_ts.u.derived->name,
+ current_ts.u.derived->ns->parent, 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
- && (current_ts.derived->components != NULL
- || current_ts.derived->attr.zero_comp))
+ && (current_ts.u.derived->components != NULL
+ || current_ts.u.derived->attr.zero_comp))
goto ok;
/* Now we have an error, which we signal, and then fix up
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_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;
+ }
+
+ 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;
- goto loop;
+ 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. */
{
gfc_symtree *stree;
if (case1)
- gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+ gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
else if (case2)
{
gfc_symtree *st2;
- gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+ 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;
}
sym->result->attr.pointer = sym->attr.pointer;
sym->result->attr.external = sym->attr.external;
sym->result->attr.referenced = sym->attr.referenced;
+ sym->result->ts = sym->ts;
sym->attr.proc_pointer = 0;
sym->attr.pointer = 0;
sym->attr.external = 0;
match_procedure_interface (gfc_symbol **proc_if)
{
match m;
+ gfc_symtree *st;
locus old_loc, entry_loc;
- old_loc = entry_loc = gfc_current_locus;
+ gfc_namespace *old_ns = gfc_current_ns;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ old_loc = entry_loc = gfc_current_locus;
gfc_clear_ts (¤t_ts);
if (gfc_match (" (") != MATCH_YES)
/* Get the type spec. for the procedure interface. */
old_loc = gfc_current_locus;
- m = gfc_match_type_spec (¤t_ts, 0);
+ m = gfc_match_decl_type_spec (¤t_ts, 0);
gfc_gobble_whitespace ();
if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
goto got_ts;
if (m == MATCH_ERROR)
return m;
+ /* Procedure interface is itself a procedure. */
gfc_current_locus = old_loc;
+ m = gfc_match_name (name);
- /* Get the name of the procedure or abstract interface
- to inherit the interface from. */
- m = gfc_match_symbol (proc_if, 1);
- if (m != MATCH_YES)
- return m;
+ /* First look to see if it is already accessible in the current
+ namespace because it is use associated or contained. */
+ st = NULL;
+ if (gfc_find_sym_tree (name, NULL, 0, &st))
+ return MATCH_ERROR;
+
+ /* If it is still not found, then try the parent namespace, if it
+ exists and create the symbol there if it is still not found. */
+ if (gfc_current_ns->parent)
+ gfc_current_ns = gfc_current_ns->parent;
+ if (st == NULL && gfc_get_ha_sym_tree (name, &st))
+ return MATCH_ERROR;
+
+ gfc_current_ns = old_ns;
+ *proc_if = st->n.sym;
/* Various interface checks. */
if (*proc_if)
return MATCH_ERROR;
}
/* Set binding label for BIND(C). */
- if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
+ if (set_binding_label (&sym->binding_label, sym->name, num)
+ != SUCCESS)
return MATCH_ERROR;
}
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;
if (m == MATCH_ERROR)
return m;
- /* TODO: Implement PASS. */
- if (!tb->nopass)
- {
- gfc_error ("Procedure Pointer Component with PASS at %C "
- "not yet implemented");
- return MATCH_ERROR;
- }
-
gfc_clear_attr (¤t_attr);
current_attr.procedure = 1;
current_attr.proc_pointer = 1;
return MATCH_ERROR;
}
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure pointer "
+ "component at %C") == FAILURE)
+ return MATCH_ERROR;
+
/* Match PPC names. */
ts = current_ts;
for(num=1;;num++)
if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
return MATCH_ERROR;
+ c->tb = tb;
+
/* Set interface. */
if (proc_if != NULL)
{
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:
|| copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
goto cleanup;
- if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
- && !sym->attr.implicit_type)
- {
- gfc_error ("Function '%s' at %C already has a type of %s", name,
- gfc_basic_typename (sym->ts.type));
- goto cleanup;
- }
-
/* Delay matching the function characteristics until after the
specification block by signalling kind=-1. */
sym->declared_at = old_loc;
if (result == NULL)
{
- sym->ts = current_ts;
+ if (current_ts.type != BT_UNKNOWN
+ && gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE)
+ goto cleanup;
sym->result = sym;
}
else
{
- result->ts = current_ts;
+ if (current_ts.type != BT_UNKNOWN
+ && gfc_add_type (result, ¤t_ts, &gfc_current_locus)
+ == FAILURE)
+ goto cleanup;
sym->result = result;
}
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;
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{
/* binding label, if exists */
- char binding_label[GFC_MAX_SYMBOL_LEN + 1];
+ const char* binding_label = NULL;
match double_quote;
match single_quote;
specifier or not. */
has_name_equals = 0;
- /* Init the first char to nil so we can catch if we don't have
- the label (name attr) or the symbol name yet. */
- binding_label[0] = '\0';
-
/* This much we have to be able to match, in this order, if
there is a bind(c) label. */
if (gfc_match (" bind ( c ") != MATCH_YES)
/* Grab the binding label, using functions that will not lower
case the names automatically. */
- if (gfc_match_name_C (binding_label) != MATCH_YES)
+ if (gfc_match_name_C (&binding_label) != MATCH_YES)
return MATCH_ERROR;
/* Get the closing quotation. */
/* Save the binding label to the symbol. If sym is null, we're
probably matching the typespec attributes of a declaration and
haven't gotten the name yet, and therefore, no symbol yet. */
- if (binding_label[0] != '\0')
+ if (binding_label)
{
if (sym != NULL)
- {
- strcpy (sym->binding_label, binding_label);
- }
+ sym->binding_label = binding_label;
else
- strcpy (curr_binding_label, binding_label);
+ curr_binding_label = binding_label;
}
else if (allow_binding_name)
{
If name="" or allow_binding_name is false, no C binding name is
created. */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
- strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
+ sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
}
if (has_name_equals && gfc_current_state () == COMP_INTERFACE
if (max_enum == NULL || enum_history == NULL)
return;
- if (!gfc_option.fshort_enums)
+ if (!flag_short_enums)
return;
i = 0;
/* Match any of the various end-block statements. Returns the type of
- END to the caller. The END INTERFACE, END IF, END DO and END
- SELECT statements cannot be replaced by a single END statement. */
+ END to the caller. The END INTERFACE, END IF, END DO, END SELECT
+ and END BLOCK statements cannot be replaced by a single END statement. */
match
gfc_match_end (gfc_statement *st)
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- 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";
+ eos_ok = 0;
+ break;
+
case COMP_IF:
*st = ST_ENDIF;
target = " if";
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;
target = " select";
eos_ok = 0;
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_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+ && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
return MATCH_YES;
- if (gfc_current_block () == NULL)
+ if (!block_name)
return MATCH_YES;
gfc_error ("Expected block name of '%s' in %s statement at %C",
if (m != MATCH_YES)
goto cleanup;
- if (find_special (name, &sym))
+ 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(). */
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ /* 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->attr.is_class)
+ {
+ if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr, &var_locus)
+ == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+ else
+ {
+ 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;
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);
{
sym_intent intent;
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("INTENT is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
intent = match_intent_spec ();
if (intent == INTENT_UNKNOWN)
return MATCH_ERROR;
match
gfc_match_optional (void)
{
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
gfc_clear_attr (¤t_attr);
current_attr.optional = 1;
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);
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_user_op *uop;
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
gfc_intrinsic_op op;
match m;
sym->name, NULL) == FAILURE)
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,
+ sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
break;
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
{
gfc_symbol *sym;
gfc_expr *init;
match m;
+ gfc_try t;
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_NO)
goto cleanup;
}
- if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl != NULL
- && sym->ts.cl->length != NULL
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT
- && init->expr_type == EXPR_CONSTANT
- && init->ts.type == BT_CHARACTER)
- gfc_set_constant_character_len (
- mpz_get_si (sym->ts.cl->length->value.integer), init, -1);
- else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL
- && sym->ts.cl->length == NULL)
- {
- int clen;
- if (init->expr_type == EXPR_CONSTANT)
- {
- clen = init->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
- }
- else if (init->expr_type == EXPR_ARRAY)
- {
- gfc_expr *p = init->value.constructor->expr;
- clen = p->value.character.length;
- sym->ts.cl->length = gfc_int_expr (clen);
- }
- else if (init->ts.cl && init->ts.cl->length)
- sym->ts.cl->length = gfc_copy_expr (sym->value->ts.cl->length);
- }
-
- sym->value = init;
- return MATCH_YES;
+ t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
+ return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
cleanup:
gfc_free_expr (init);
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;
gfc_symbol *sym;
match m;
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("VALUE is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
== FAILURE)
return MATCH_ERROR;
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;
module_ns = gfc_current_ns->parent;
for (; module_ns; module_ns = module_ns->parent)
- if (module_ns->proc_name->attr.flavor == FL_MODULE)
+ if (module_ns->proc_name->attr.flavor == FL_MODULE
+ || module_ns->proc_name->attr.flavor == FL_PROGRAM
+ || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
+ && !module_ns->proc_name->attr.contained))
break;
if (module_ns == NULL)
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 (;;)
{
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;
if (gfc_get_symbol (name, module_ns, &sym))
return MATCH_ERROR;
+ if (sym->attr.intrinsic)
+ {
+ gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
+ "PROCEDURE", &old_locus);
+ return MATCH_ERROR;
+ }
+
if (sym->attr.proc != PROC_MODULE
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
sym->attr.mod_proc = 1;
+ sym->declared_at = old_locus;
if (last)
break;
while (interface != old_interface_head)
{
gfc_interface *i = interface->next;
- gfc_free (interface);
+ free (interface);
interface = i;
}
return NULL;
}
+ extended = gfc_find_dt_in_generic (extended);
+
if (extended->attr.flavor != FL_DERIVED)
{
gfc_error ("'%s' in EXTENDS expression at %C is not a "
char name[GFC_MAX_SYMBOL_LEN + 1];
char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
- gfc_symbol *sym;
+ gfc_symbol *sym, *gensym;
gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
+ gfc_interface *intr = NULL, *head;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
return MATCH_ERROR;
}
- if (gfc_get_symbol (name, NULL, &sym))
+ if (gfc_get_symbol (name, NULL, &gensym))
return MATCH_ERROR;
- if (sym->ts.type != BT_UNKNOWN)
+ if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
gfc_error ("Derived type name '%s' at %C already has a basic type "
- "of %s", sym->name, gfc_typename (&sym->ts));
+ "of %s", gensym->name, gfc_typename (&gensym->ts));
+ return MATCH_ERROR;
+ }
+
+ if (!gensym->attr.generic
+ && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ if (!gensym->attr.function
+ && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ sym = gfc_find_dt_in_generic (gensym);
+
+ if (sym && (sym->components != NULL || sym->attr.zero_comp))
+ {
+ gfc_error ("Derived type definition of '%s' at %C has already been "
+ "defined", sym->name);
return MATCH_ERROR;
}
+ 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);
+ head = gensym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = sym;
+ intr->where = gfc_current_locus;
+ intr->sym->declared_at = gfc_current_locus;
+ intr->next = head;
+ gensym->generic = intr;
+ gensym->attr.if_source = IFSRC_DECL;
+ }
+
/* The symbol may already have the derived attribute without the
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
- if (sym->components != NULL || sym->attr.zero_comp)
- {
- gfc_error ("Derived type definition of '%s' at %C has already been "
- "defined", sym->name);
- return MATCH_ERROR;
- }
-
if (attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
+ else if (sym->attr.access == ACCESS_UNKNOWN
+ && gensym->attr.access != ACCESS_UNKNOWN
+ && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (sym->attr.access != ACCESS_UNKNOWN
+ && gensym->attr.access == ACCESS_UNKNOWN)
+ gensym->attr.access = sym->attr.access;
/* See if the derived type was labeled as bind(c). */
if (attr.is_bind_c != 0)
/* 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.derived = extended;
+ 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->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");
}
+/* Returns an initializer whose value is one higher than the value of the
+ LAST_INITIALIZER argument. If the argument is NULL, the
+ initializers value will be set to zero. The initializer's kind
+ will be set to gfc_c_int_kind.
+
+ If -fshort-enums is given, the appropriate kind will be selected
+ later after all enumerators have been parsed. A warning is issued
+ here if an initializer exceeds gfc_c_int_kind. */
+
+static gfc_expr *
+enum_initializer (gfc_expr *last_initializer, locus where)
+{
+ gfc_expr *result;
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
+
+ mpz_init (result->value.integer);
+
+ if (last_initializer != NULL)
+ {
+ mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
+ result->where = last_initializer->where;
+
+ if (gfc_check_integer_range (result->value.integer,
+ gfc_c_int_kind) != ARITH_OK)
+ {
+ gfc_error ("Enumerator exceeds the C integer type at %C");
+ return NULL;
+ }
+ }
+ else
+ {
+ /* Control comes here, if it's the very first enumerator and no
+ initializer has been given. It will be initialized to zero. */
+ mpz_set_si (result->value.integer, 0);
+ }
+
+ return result;
+}
+
+
/* 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
/* 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;
previous enumerator (stored in last_initializer) is incremented
by 1 and is used to initialize the current enumerator. */
if (initializer == NULL)
- initializer = gfc_enum_initializer (last_initializer, old_locus);
+ initializer = enum_initializer (last_initializer, old_locus);
if (initializer == NULL || initializer->ts.type != BT_INTEGER)
{
- gfc_error("ENUMERATOR %L not initialized with integer expression",
- &var_locus);
+ 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;
{
bool found_passing = false;
bool seen_ptr = false;
- match m;
+ match m = MATCH_YES;
/* Intialize to defaults. Do so even before the MATCH_NO check so that in
this case the defaults are in there. */
ba->nopass = 0;
ba->non_overridable = 0;
ba->deferred = 0;
+ ba->ppc = ppc;
/* If we find a comma, we believe there are binding attributes. */
- if (gfc_match_char (',') == MATCH_NO)
- {
- ba->access = gfc_typebound_default_access;
- return MATCH_NO;
- }
+ m = gfc_match_char (',');
+ if (m == MATCH_NO)
+ goto done;
do
{
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
- ba->pass_arg = xstrdup (arg);
+ ba->pass_arg = gfc_get_string (arg);
gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
found_passing = true;
}
seen_ptr = true;
- /*ba->ppc = 1;*/
continue;
}
}
goto error;
}
+ m = MATCH_YES;
+
+done:
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
goto error;
}
- return MATCH_YES;
+ return m;
error:
- gfc_free (ba->pass_arg);
return MATCH_ERROR;
}
{
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))
- 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;
}
gfc_match_generic (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
gfc_symbol* block;
gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
gfc_typebound_proc* tb;
- gfc_symtree* st;
gfc_namespace* ns;
+ interface_type op_type;
+ gfc_intrinsic_op op;
match m;
/* Check current state. */
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)
goto error;
}
- /* The binding name and =>. */
- m = gfc_match (" %n =>", name);
+ /* Match the binding name; depending on type (operator / generic) format
+ it for future error messages into bind_name. */
+
+ m = gfc_match_generic_spec (&op_type, name, &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
{
- gfc_error ("Expected generic name at %C");
+ gfc_error ("Expected generic name or operator descriptor at %C");
+ goto error;
+ }
+
+ switch (op_type)
+ {
+ case INTERFACE_GENERIC:
+ snprintf (bind_name, sizeof (bind_name), "%s", name);
+ break;
+
+ case INTERFACE_USER_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
+ break;
+
+ case INTERFACE_INTRINSIC_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
+ gfc_op2string (op));
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ /* Match the required =>. */
+ if (gfc_match (" =>") != MATCH_YES)
+ {
+ gfc_error ("Expected '=>' at %C");
goto error;
}
+
+ /* Try to find existing GENERIC binding with this name / for this operator;
+ if there is something, check that it is another GENERIC and then extend
+ it rather than building a new node. Otherwise, create it and put it
+ at the right position. */
- /* If there's already something with this name, check that it is another
- GENERIC and then extend that rather than build a new node. */
- st = gfc_find_symtree (ns->tb_sym_root, name);
- if (st)
+ switch (op_type)
{
- gcc_assert (st->n.tb);
- tb = st->n.tb;
+ case INTERFACE_USER_OP:
+ case INTERFACE_GENERIC:
+ {
+ const bool is_op = (op_type == INTERFACE_USER_OP);
+ 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;
+
+ break;
+ }
+
+ case INTERFACE_INTRINSIC_OP:
+ tb = ns->tb_op[op];
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ if (tb)
+ {
if (!tb->is_generic)
{
+ gcc_assert (op_type == INTERFACE_GENERIC);
gfc_error ("There's already a non-generic procedure with binding name"
" '%s' for the derived type '%s' at %C",
- name, block->name);
+ bind_name, block->name);
goto error;
}
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
- " defined binding '%s'", name);
+ " defined binding '%s'", bind_name);
goto error;
}
}
else
{
- st = gfc_new_symtree (&ns->tb_sym_root, name);
- gcc_assert (st);
-
- st->n.tb = tb = gfc_get_typebound_proc ();
+ tb = gfc_get_typebound_proc (NULL);
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
tb->u.generic = NULL;
+
+ switch (op_type)
+ {
+ 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);
+ gcc_assert (st);
+ st->n.tb = tb;
+
+ break;
+ }
+
+ case INTERFACE_INTRINSIC_OP:
+ ns->tb_op[op] = tb;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
}
/* Now, match all following names as specific targets. */
if (target_st == target->specific_st)
{
gfc_error ("'%s' already defined as specific binding for the"
- " generic '%s' at %C", name, st->name);
+ " generic '%s' at %C", name, bind_name);
goto error;
}
target->specific_st = target_st;
target->specific = NULL;
target->next = tb->u.generic;
+ target->is_operator = ((op_type == INTERFACE_USER_OP)
+ || (op_type == INTERFACE_INTRINSIC_OP));
tb->u.generic = target;
}
while (gfc_match (" ,") == MATCH_YES);
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;
return MATCH_YES;
}
+
+
+const ext_attr_t ext_attr_list[] = {
+ { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
+ { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
+ { "cdecl", EXT_ATTR_CDECL, "cdecl" },
+ { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
+ { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
+ { NULL, EXT_ATTR_LAST, NULL }
+};
+
+/* Match a !GCC$ ATTRIBUTES statement of the form:
+ !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
+ When we come here, we have already matched the !GCC$ ATTRIBUTES string.
+
+ TODO: We should support all GCC attributes using the same syntax for
+ the attribute list, i.e. the list in C
+ __attributes(( attribute-list ))
+ matches then
+ !GCC$ ATTRIBUTES attribute-list ::
+ Cf. c-parser.c's c_parser_attributes; the data can then directly be
+ saved into a TREE.
+
+ As there is absolutely no risk of confusion, we should never return
+ MATCH_NO. */
+match
+gfc_match_gcc_attributes (void)
+{
+ symbol_attribute attr;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ unsigned id;
+ gfc_symbol *sym;
+ match m;
+
+ gfc_clear_attr (&attr);
+ for(;;)
+ {
+ char ch;
+
+ if (gfc_match_name (name) != MATCH_YES)
+ return MATCH_ERROR;
+
+ for (id = 0; id < EXT_ATTR_LAST; id++)
+ if (strcmp (name, ext_attr_list[id].name) == 0)
+ break;
+
+ if (id == EXT_ATTR_LAST)
+ {
+ gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_add_ext_attribute (&attr, (ext_attr_id_t) id, &gfc_current_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_gobble_whitespace ();
+ ch = gfc_next_ascii_char ();
+ if (ch == ':')
+ {
+ /* This is the successful exit condition for the loop. */
+ if (gfc_next_ascii_char () == ':')
+ break;
+ }
+
+ if (ch == ',')
+ continue;
+
+ goto syntax;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ goto syntax;
+
+ for(;;)
+ {
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ return m;
+
+ if (find_special (name, &sym, true))
+ return MATCH_ERROR;
+
+ sym->attr.ext_attr |= attr.ext_attr;
+
+ if (gfc_match_eos () == MATCH_YES)
+ break;
+
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
+ return MATCH_ERROR;
+}
OSDN Git Service
