/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
/************************ 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. */
dimension attribute. */
attr = current_attr;
attr.dimension = 0;
+ attr.codimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
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
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);
char_len = NULL;
cl = NULL;
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");
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,
+ DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE,
GFC_DECL_END /* Sentinel */
}
decl_types;
switch (gfc_peek_ascii_char ())
{
case 'a':
- if (match_string_p ("allocatable"))
- d = DECL_ALLOCATABLE;
- break;
+ 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;
+ }
case 'b':
/* Try and match the bind(c). */
goto cleanup;
break;
+ case 'c':
+ if (match_string_p ("codimension"))
+ d = DECL_CODIMENSION;
+ 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_ALLOCATABLE:
attr = "ALLOCATABLE";
break;
+ case DECL_ASYNCHRONOUS:
+ attr = "ASYNCHRONOUS";
+ break;
+ case DECL_CODIMENSION:
+ attr = "CODIMENSION";
+ 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_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_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
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;
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 (*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_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))
{
}
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;
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_dimension (void)
{
gfc_clear_attr (¤t_attr);
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. */
/* 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");
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 first, last;
gfc_symbol* block;
+ if (gfc_current_form == FORM_FREE)
+ {
+ char c = gfc_peek_ascii_char ();
+ if (!gfc_is_whitespace (c) && c != ':')
+ return MATCH_NO;
+ }
+
if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
+ if (gfc_current_form == FORM_FIXED)
+ return MATCH_NO;
+
gfc_error ("FINAL declaration at %C must be inside a derived type "
"CONTAINS section");
return MATCH_ERROR;
OSDN Git Service
