#include "match.h"
#include "parse.h"
#include "flags.h"
-
+#include "constructor.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
for (; p; p = q)
{
q = p->next;
+ mpz_clear (p->repeat);
gfc_free_expr (p->expr);
gfc_free (p);
}
/************************ 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. */
if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
- *expr = gfc_int_expr (length);
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
}
/* 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 "
+ "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,
dimension attribute. */
attr = current_attr;
attr.dimension = 0;
+ attr.codimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
sym->attr.implied_index = 0;
- if (sym->ts.type == BT_CLASS)
- {
- sym->attr.class_ok = (sym->attr.dummy
- || sym->attr.pointer
- || sym->attr.allocatable) ? 1 : 0;
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
- }
+ if (sym->ts.type == BT_CLASS
+ && (sym->attr.class_ok = sym->attr.dummy || sym->attr.pointer
+ || sym->attr.allocatable))
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return SUCCESS;
}
}
/* Check if the assignment can happen. This has to be put off
- until later for a derived type variable. */
+ until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
+ && !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
- gfc_expr *p = init->value.constructor->expr;
- clen = p->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ gfc_constructor *c;
+ c = gfc_constructor_first (init->value.constructor);
+ clen = c->expr->value.character.length;
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, clen);
}
else if (init->ts.u.cl && init->ts.u.cl->length)
sym->ts.u.cl->length =
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
- gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
+ gfc_constructor *c;
+
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
- for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, -1);
+ for (c = gfc_constructor_first (init->value.constructor);
+ c; c = gfc_constructor_next (c))
+ gfc_set_constant_character_len (len, c->expr, -1);
+ }
+ }
+ }
+
+ /* If sym is implied-shape, set its upper bounds from init. */
+ if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
+ && sym->as->type == AS_IMPLIED_SHAPE)
+ {
+ int dim;
+
+ if (init->rank == 0)
+ {
+ gfc_error ("Can't initialize implied-shape array at %L"
+ " with scalar", &sym->declared_at);
+ return FAILURE;
+ }
+ gcc_assert (sym->as->rank == init->rank);
+
+ /* Shape should be present, we get an initialization expression. */
+ gcc_assert (init->shape);
+
+ for (dim = 0; dim < sym->as->rank; ++dim)
+ {
+ int k;
+ gfc_expr* lower;
+ gfc_expr* e;
+
+ lower = sym->as->lower[dim];
+ if (lower->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Non-constant lower bound in implied-shape"
+ " declaration at %L", &lower->where);
+ return FAILURE;
}
+
+ /* All dimensions must be without upper bound. */
+ gcc_assert (!sym->as->upper[dim]);
+
+ k = lower->ts.kind;
+ e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
+ mpz_add (e->value.integer,
+ lower->value.integer, init->shape[dim]);
+ mpz_sub_ui (e->value.integer, e->value.integer, 1);
+ sym->as->upper[dim] = e;
}
+
+ sym->as->type = AS_EXPLICIT;
}
/* Need to check if the expression we initialized this
if (init->ts.is_iso_c)
sym->ts.f90_type = init->ts.f90_type;
}
-
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
mpz_t size;
gfc_expr *array;
- gfc_constructor *c;
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
&& spec_size (sym->as, &size) == SUCCESS
&& mpz_cmp_si (size, 0) > 0)
{
- array = gfc_start_constructor (init->ts.type, init->ts.kind,
- &init->where);
-
- array->value.constructor = c = NULL;
+ array = gfc_get_array_expr (init->ts.type, init->ts.kind,
+ &init->where);
for (n = 0; n < (int)mpz_get_si (size); n++)
- {
- if (array->value.constructor == NULL)
- {
- array->value.constructor = c = gfc_get_constructor ();
- c->expr = init;
- }
- else
- {
- c->next = gfc_get_constructor ();
- c = c->next;
- c->expr = gfc_copy_expr (init);
- }
- }
-
+ gfc_constructor_append_expr (&array->value.constructor,
+ n == 0
+ ? init
+ : gfc_copy_expr (init),
+ &init->where);
+
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
c->as = *as;
if (c->as != NULL)
- c->attr.dimension = 1;
+ {
+ if (c->as->corank)
+ c->attr.codimension = 1;
+ if (c->as->rank)
+ c->attr.dimension = 1;
+ }
*as = NULL;
/* Should this ever get more complicated, combine with similar section
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
- bool has_ts;
- gfc_constructor *ctor = c->initializer->value.constructor;
-
- has_ts = (c->initializer->ts.u.cl
- && c->initializer->ts.u.cl->length_from_typespec);
+ gfc_constructor *ctor;
+ ctor = gfc_constructor_first (c->initializer->value.constructor);
if (ctor)
{
int first_len;
+ bool has_ts = (c->initializer->ts.u.cl
+ && c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
- for (; ctor; ctor = ctor->next)
+ for ( ; ctor; ctor = gfc_constructor_next (ctor))
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
{
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
+ gfc_set_constant_character_len (len, ctor->expr,
+ has_ts ? -1 : first_len);
+ ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
}
}
}
scalar:
if (c->ts.type == BT_CLASS)
- gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+ gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
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);
- *result = e;
+ 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_procptr_assignment = procptr;
+ m = gfc_match_rvalue (init);
+ gfc_matching_procptr_assignment = 0;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ else if (m == MATCH_NO)
+ {
+ gfc_error ("Error in pointer initialization at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!procptr)
+ gfc_resolve_expr (*init);
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
+ "initialization at %C") == FAILURE)
+ return MATCH_ERROR;
return MATCH_YES;
}
var_locus = gfc_current_locus;
/* Now we could see the optional array spec. or character length. */
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, true, true);
if (gfc_option.flag_cray_pointer && m == MATCH_YES)
cp_as = gfc_copy_array_spec (as);
else if (m == MATCH_ERROR)
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
+ else if (current_as)
+ merge_array_spec (current_as, as, true);
+
+ /* 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;
specified in the procedure definition, except that the interface
may specify a procedure that is not pure if the procedure is
defined to be pure(12.3.2). */
- if (current_ts.type == BT_DERIVED
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& current_ts.u.derived->ns != gfc_current_ns)
goto cleanup;
}
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
-
- if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 0);
if (m != MATCH_YES)
goto cleanup;
-
}
else if (gfc_match_char ('=') == MATCH_YES)
{
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;
gfc_symbol *sym;
match m;
char c;
- bool seen_deferred_kind;
+ bool seen_deferred_kind, matched_type;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
return MATCH_YES;
}
- if (gfc_match (" integer") == MATCH_YES)
+
+ m = gfc_match (" type ( %n", name);
+ matched_type = (m == MATCH_YES);
+
+ if ((matched_type && strcmp ("integer", name) == 0)
+ || (!matched_type && gfc_match (" integer") == MATCH_YES))
{
ts->type = BT_INTEGER;
ts->kind = gfc_default_integer_kind;
goto get_kind;
}
- if (gfc_match (" character") == MATCH_YES)
+ if ((matched_type && strcmp ("character", name) == 0)
+ || (!matched_type && gfc_match (" character") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
- return gfc_match_char_spec (ts);
+ m = gfc_match_char_spec (ts);
else
- return MATCH_YES;
+ m = MATCH_YES;
+
+ if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+ m = MATCH_ERROR;
+
+ return m;
}
- if (gfc_match (" real") == MATCH_YES)
+ if ((matched_type && strcmp ("real", name) == 0)
+ || (!matched_type && gfc_match (" real") == MATCH_YES))
{
ts->type = BT_REAL;
ts->kind = gfc_default_real_kind;
goto get_kind;
}
- if (gfc_match (" double precision") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doubleprecision", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" precision") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
- if (gfc_match (" complex") == MATCH_YES)
+ if ((matched_type && strcmp ("complex", name) == 0)
+ || (!matched_type && gfc_match (" complex") == MATCH_YES))
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_complex_kind;
goto get_kind;
}
- if (gfc_match (" double complex") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doublecomplex", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" complex") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
- if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
- "conform to the Fortran 95 standard") == FAILURE)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
ts->type = BT_COMPLEX;
return MATCH_YES;
}
- if (gfc_match (" logical") == MATCH_YES)
+ if ((matched_type && strcmp ("logical", name) == 0)
+ || (!matched_type && gfc_match (" logical") == MATCH_YES))
{
ts->type = BT_LOGICAL;
ts->kind = gfc_default_logical_kind;
goto get_kind;
}
- m = gfc_match (" type ( %n )", name);
+ if (matched_type)
+ m = gfc_match_char (')');
+
if (m == MATCH_YES)
ts->type = BT_DERIVED;
else
return MATCH_YES;
get_kind:
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
/* For all types except double, derived and character, look for an
optional kind specifier. MATCH_NO is actually OK at this point. */
if (implicit_flag == 1)
- return MATCH_YES;
+ {
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+ }
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_ascii_char ();
if (!gfc_is_whitespace (c) && c != '*' && c != '('
&& c != ':' && c != ',')
- return MATCH_NO;
+ {
+ if (matched_type && c == ')')
+ {
+ gfc_next_ascii_char ();
+ return MATCH_YES;
+ }
+ return MATCH_NO;
+ }
}
m = gfc_match_kind_spec (ts, false);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
/* Defer association of the KIND expression of function results
until after USE and IMPORT statements. */
if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
{
ts.kind = gfc_default_character_kind;
ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- ts.u.cl->length = gfc_int_expr (1);
+ ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
/* Record the Successful match. */
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_ASYNCHRONOUS, DECL_NONE,
- GFC_DECL_END /* Sentinel */
+ DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+ DECL_NONE, GFC_DECL_END /* Sentinel */
}
decl_types;
}
break;
}
+ break;
case 'b':
/* Try and match the bind(c). */
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);
+ gfc_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_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_asynchronous (¤t_attr, NULL, &seen_at[d]);
break;
+ case DECL_CODIMENSION:
+ t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
+ break;
+
+ case DECL_CONTIGUOUS:
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: CONTIGUOUS attribute at %C")
+ == FAILURE)
+ t = FAILURE;
+ else
+ t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
}
}
+ /* Module variables implicitly have the SAVE attribute. */
+ if (gfc_current_state () == COMP_MODULE && !current_attr.save)
+ current_attr.save = SAVE_IMPLICIT;
+
colon_seen = 1;
return MATCH_YES;
verify_c_interop (gfc_typespec *ts)
{
if (ts->type == BT_DERIVED && ts->u.derived != NULL)
- return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
+ ? SUCCESS : FAILURE;
else if (ts->is_c_interop != 1)
return FAILURE;
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
+ bool seen_impure;
+ bool found_prefix;
gfc_clear_attr (¤t_attr);
- seen_type = 0;
+ seen_type = false;
+ seen_impure = false;
gcc_assert (!gfc_matching_prefix);
gfc_matching_prefix = true;
-loop:
- if (!seen_type && ts != NULL
- && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
- && gfc_match_space () == MATCH_YES)
+ do
{
+ found_prefix = false;
- seen_type = 1;
- goto loop;
- }
+ if (!seen_type && ts != NULL
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_space () == MATCH_YES)
+ {
- if (gfc_match ("elemental% ") == MATCH_YES)
- {
- if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- goto error;
+ seen_type = true;
+ found_prefix = true;
+ }
+
+ if (gfc_match ("elemental% ") == MATCH_YES)
+ {
+ if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
- goto loop;
+ if (gfc_match ("pure% ") == MATCH_YES)
+ {
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("recursive% ") == MATCH_YES)
+ {
+ if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ /* IMPURE is a somewhat special case, as it needs not set an actual
+ attribute but rather only prevents ELEMENTAL routines from being
+ automatically PURE. */
+ if (gfc_match ("impure% ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: IMPURE procedure at %C")
+ == FAILURE)
+ goto error;
+
+ seen_impure = true;
+ found_prefix = true;
+ }
}
+ while (found_prefix);
- if (gfc_match ("pure% ") == MATCH_YES)
+ /* IMPURE and PURE must not both appear, of course. */
+ if (seen_impure && current_attr.pure)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- goto error;
-
- goto loop;
+ gfc_error ("PURE and IMPURE must not appear both at %C");
+ goto error;
}
- if (gfc_match ("recursive% ") == MATCH_YES)
+ /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
+ if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
- if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
goto error;
-
- goto loop;
}
/* At this point, the next item is not a prefix. */
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 (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);
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)
{
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
- block_name = NULL;
-
- if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
+ switch (state)
{
+ case COMP_ASSOCIATE:
+ case COMP_BLOCK:
+ if (!strcmp (block_name, "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_CRITICAL:
+ *st = ST_END_CRITICAL;
+ target = " critical";
+ eos_ok = 0;
+ break;
+
case COMP_SELECT:
case COMP_SELECT_TYPE:
*st = ST_END_SELECT;
if (gfc_match_eos () == MATCH_YES)
{
- if (!eos_ok)
+ if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
+ "instead of %s statement at %L",
+ gfc_ascii_statement (*st), &old_loc) == FAILURE)
+ goto cleanup;
+ }
+ else if (!eos_ok)
{
/* We would have required END [something]. */
gfc_error ("%s statement expected at %L",
{
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
- && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
+ && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+ && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
return MATCH_YES;
if (!block_name)
/* Deal with possible array specification for certain attributes. */
if (current_attr.dimension
+ || current_attr.codimension
|| current_attr.allocatable
|| current_attr.pointer
|| current_attr.target)
{
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, !current_attr.codimension,
+ !current_attr.dimension
+ && !current_attr.pointer
+ && !current_attr.target);
if (m == MATCH_ERROR)
goto cleanup;
goto cleanup;
}
+ if (current_attr.codimension && m == MATCH_NO)
+ {
+ gfc_error ("Missing array specification at %L in CODIMENSION "
+ "statement", &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
if ((current_attr.allocatable || current_attr.pointer)
&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
{
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
to the first component, or '$data' field. */
- if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
{
- gfc_component *comp;
- comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
- if (comp == NULL || gfc_copy_attr (&comp->attr, ¤t_attr,
- &var_locus) == FAILURE)
+ if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus)
+ == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
- sym->attr.class_ok = (sym->attr.class_ok
- || current_attr.allocatable
- || current_attr.pointer);
}
else
{
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ if (current_attr.dimension == 0 && current_attr.codimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
+
+ if (sym->ts.type == BT_CLASS && !sym->attr.class_ok
+ && (sym->attr.class_ok = sym->attr.class_ok || current_attr.allocatable
+ || current_attr.pointer))
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
{
cray_pointer_decl (void)
{
match m;
- gfc_array_spec *as;
+ gfc_array_spec *as = NULL;
gfc_symbol *cptr; /* Pointer symbol. */
gfc_symbol *cpte; /* Pointee symbol. */
locus var_locus;
}
/* Check for an optional array spec. */
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, true, false);
if (m == MATCH_ERROR)
{
gfc_free_array_spec (as);
match
+gfc_match_codimension (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.codimension = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_contiguous (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.contiguous = 1;
+
+ return attr_decl ();
+}
+
+
+match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
for(;;)
{
/* VOLATILE is special because it can be added to host-associated
- symbols locally. */
+ symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
+ /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
+ for variable in a BLOCK which is defined outside of the BLOCK. */
+ if (sym->ns != gfc_current_ns && sym->attr.codimension)
+ {
+ gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+ "%C, which is use-/host-associated", sym->name);
+ return MATCH_ERROR;
+ }
if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
enum_initializer (gfc_expr *last_initializer, locus where)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = gfc_c_int_kind;
- result->where = where;
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
mpz_init (result->value.integer);
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char target_buf[GFC_MAX_SYMBOL_LEN + 1];
- char* target = NULL;
- gfc_typebound_proc* tb;
+ char* target = NULL, *ifc = NULL;
+ gfc_typebound_proc tb;
bool seen_colons;
bool seen_attrs;
match m;
gfc_symtree* stree;
gfc_namespace* ns;
gfc_symbol* block;
+ int num;
/* Check current state. */
gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
return MATCH_ERROR;
}
- target = target_buf;
+ ifc = target_buf;
}
/* Construct the data structure. */
- tb = gfc_get_typebound_proc ();
- tb->where = gfc_current_locus;
- tb->is_generic = 0;
+ memset (&tb, 0, sizeof (tb));
+ tb.where = gfc_current_locus;
/* Match binding attributes. */
- m = match_binding_attributes (tb, false, false);
+ m = match_binding_attributes (&tb, false, false);
if (m == MATCH_ERROR)
return m;
seen_attrs = (m == MATCH_YES);
- /* Check that attribute DEFERRED is given iff an interface is specified, which
- means target != NULL. */
- if (tb->deferred && !target)
+ /* Check that attribute DEFERRED is given if an interface is specified. */
+ if (tb.deferred && !ifc)
{
gfc_error ("Interface must be specified for DEFERRED binding at %C");
return MATCH_ERROR;
}
- if (target && !tb->deferred)
+ if (ifc && !tb.deferred)
{
gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
return MATCH_ERROR;
return MATCH_ERROR;
}
- /* Match the binding name. */
- m = gfc_match_name (name);
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Expected binding name at %C");
- return MATCH_ERROR;
- }
-
- /* Try to match the '=> target', if it's there. */
- m = gfc_match (" =>");
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_YES)
+ /* Match the binding names. */
+ for(num=1;;num++)
{
- if (tb->deferred)
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
{
- gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ gfc_error ("Expected binding name at %C");
return MATCH_ERROR;
}
- if (!seen_colons)
- {
- gfc_error ("'::' needed in PROCEDURE binding with explicit target"
- " at %C");
- return MATCH_ERROR;
- }
+ if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+ " at %C") == FAILURE)
+ return MATCH_ERROR;
- m = gfc_match_name (target_buf);
+ /* Try to match the '=> target', if it's there. */
+ target = ifc;
+ m = gfc_match (" =>");
if (m == MATCH_ERROR)
return m;
- if (m == MATCH_NO)
+ if (m == MATCH_YES)
{
- gfc_error ("Expected binding target after '=>' at %C");
- return MATCH_ERROR;
+ if (tb.deferred)
+ {
+ gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!seen_colons)
+ {
+ gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
}
- target = target_buf;
- }
- /* Now we should have the end. */
- m = gfc_match_eos ();
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Junk after PROCEDURE declaration at %C");
- return MATCH_ERROR;
- }
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
- /* If no target was found, it has the same name as the binding. */
- if (!target)
- target = name;
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
- /* Get the namespace to insert the symbols into. */
- ns = block->f2k_derived;
- gcc_assert (ns);
+ /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
+ if (tb.deferred && !block->attr.abstract)
+ {
+ gfc_error ("Type '%s' containing DEFERRED binding at %C "
+ "is not ABSTRACT", block->name);
+ return MATCH_ERROR;
+ }
- /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
- if (tb->deferred && !block->attr.abstract)
- {
- gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
- block->name);
- return MATCH_ERROR;
- }
+ /* See if we already have a binding with this name in the symtree which
+ would be an error. If a GENERIC already targetted this binding, it may
+ be already there but then typebound is still NULL. */
+ stree = gfc_find_symtree (ns->tb_sym_root, name);
+ if (stree && stree->n.tb)
+ {
+ gfc_error ("There is already a procedure with binding name '%s' for "
+ "the derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
- /* See if we already have a binding with this name in the symtree which would
- be an error. If a GENERIC already targetted this binding, it may be
- already there but then typebound is still NULL. */
- stree = gfc_find_symtree (ns->tb_sym_root, name);
- if (stree && stree->n.tb)
- {
- gfc_error ("There's already a procedure with binding name '%s' for the"
- " derived type '%s' at %C", name, block->name);
- return MATCH_ERROR;
- }
+ /* Insert it and set attributes. */
- /* Insert it and set attributes. */
+ if (!stree)
+ {
+ stree = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (stree);
+ }
+ stree->n.tb = gfc_get_typebound_proc (&tb);
- if (!stree)
- {
- stree = gfc_new_symtree (&ns->tb_sym_root, name);
- gcc_assert (stree);
+ if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
+ false))
+ return MATCH_ERROR;
+ gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
+
+ if (gfc_match_eos () == MATCH_YES)
+ return MATCH_YES;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
}
- stree->n.tb = tb;
-
- if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
- return MATCH_ERROR;
- gfc_set_sym_referenced (tb->u.specific->n.sym);
- return MATCH_YES;
+syntax:
+ gfc_error ("Syntax error in PROCEDURE statement at %C");
+ return MATCH_ERROR;
}
ns = block->f2k_derived;
gcc_assert (block && ns);
+ memset (&tbattr, 0, sizeof (tbattr));
+ tbattr.where = gfc_current_locus;
+
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true, false);
if (m == MATCH_ERROR)
}
else
{
- tb = gfc_get_typebound_proc ();
+ tb = gfc_get_typebound_proc (NULL);
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
OSDN Git Service
