/* 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. */
}
+
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
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);
+ }
+
return SUCCESS;
}
/* Check if the assignment can happen. This has to be put off
until later for a derived type variable. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
+ && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
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.u.cl = gfc_new_charlen (gfc_current_ns);
+ sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
if (sym->attr.flavor == FL_PARAMETER)
{
{
/* 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);
+ 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_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
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
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
/* 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)
+ gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+
+ return t;
}
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);
+ 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;
switch (match_char_length (&char_len))
{
case MATCH_YES:
- cl = gfc_new_charlen (gfc_current_ns);
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
cl->length = char_len;
break;
&& (current_ts.u.cl->length == NULL
|| current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
{
- cl = gfc_new_charlen (gfc_current_ns);
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
cl->length = gfc_copy_expr (current_ts.u.cl->length);
}
else
m = MATCH_ERROR;
}
- if (gfc_pure (NULL))
+ 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;
}
- 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 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;
}
/* Do some final massaging of the length values. */
- cl = gfc_new_charlen (gfc_current_ns);
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
if (seen_length == 0)
cl->length = gfc_int_expr (1);
}
-/* 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;
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;
{
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
- return match_char_spec (ts);
+ return gfc_match_char_spec (ts);
else
return MATCH_YES;
}
}
m = gfc_match (" type ( %n )", name);
- if (m != MATCH_YES)
+ if (m == MATCH_YES)
+ ts->type = BT_DERIVED;
+ else
{
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
- ts->is_class = 1;
+ ts->type = BT_CLASS;
- /* TODO: Implement Polymorphism. */
- gfc_warning ("Polymorphic entities are not yet implemented. "
- "CLASS will be treated like TYPE at %C");
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
}
- ts->type = BT_DERIVED;
-
/* 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_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;
}
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 (ts.type == BT_CHARACTER && !ts.u.cl)
{
ts.kind = gfc_default_character_kind;
- ts.u.cl = gfc_new_charlen (gfc_current_ns);
+ ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
ts.u.cl->length = gfc_int_expr (1);
}
/* 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);
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;
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.u.derived);
goto cleanup;
}
- if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
{
loop:
if (!seen_type && ts != NULL
- && gfc_match_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == 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;
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 (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;
/* 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_BLOCK && !strcmp (block_name, "block@"))
+ block_name = NULL;
+
if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
{
state = gfc_state_stack->previous->state;
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";
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 (*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_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",
/* 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)
{
- m = MATCH_ERROR;
- goto cleanup;
+ 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)
+ {
+ 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 && current_attr.codimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
}
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
cray_pointer_decl (void)
{
match m;
- gfc_array_spec *as;
+ gfc_array_spec *as = NULL;
gfc_symbol *cptr; /* Pointer symbol. */
gfc_symbol *cpte; /* Pointee symbol. */
locus var_locus;
}
/* Check for an optional array spec. */
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, true, false);
if (m == MATCH_ERROR)
{
gfc_free_array_spec (as);
{
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_dimension (void)
{
gfc_clear_attr (¤t_attr);
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.u.cl != NULL
- && sym->ts.u.cl->length != NULL
- && sym->ts.u.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.u.cl->length->value.integer), init, -1);
- else if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl != NULL
- && sym->ts.u.cl->length == NULL)
- {
- int clen;
- if (init->expr_type == EXPR_CONSTANT)
- {
- clen = init->value.character.length;
- sym->ts.u.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.u.cl->length = gfc_int_expr (clen);
- }
- 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);
- }
-
- 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);
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. */
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)
for (;;)
{
+ locus old_locus = gfc_current_locus;
bool last = false;
m = gfc_match_name (name);
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;
}
+/* Assign a hash value for a derived type. The algorithm is that of
+ SDBM. The hashed string is '[module_name #] derived_name'. */
+static unsigned int
+hash_value (gfc_symbol *sym)
+{
+ unsigned int hash = 0;
+ const char *c;
+ int i, len;
+
+ /* Hash of the module or procedure name. */
+ if (sym->module != NULL)
+ c = sym->module;
+ else if (sym->ns && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ c = sym->ns->proc_name->name;
+ else
+ c = NULL;
+
+ if (c)
+ {
+ len = strlen (c);
+ for (i = 0; i < len; i++, c++)
+ hash = (hash << 6) + (hash << 16) - hash + (*c);
+
+ /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */
+ hash = (hash << 6) + (hash << 16) - hash + '#';
+ }
+
+ /* Hash of the derived type name. */
+ len = strlen (sym->name);
+ c = sym->name;
+ for (i = 0; i < len; i++, c++)
+ hash = (hash << 6) + (hash << 16) - hash + (*c);
+
+ /* Return the hash but take the modulus for the sake of module read,
+ even though this slightly increases the chance of collision. */
+ return (hash % 100000000);
+}
+
+
/* Match the beginning of a derived type declaration. If a type name
was the result of a function, then it is possible to have a symbol
already to be known as a derived type yet have no components. */
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
- sym->attr.extension = attr.extension;
extended->refs++;
gfc_set_sym_referenced (extended);
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
+
+ /* Set extension level. */
+ if (extended->attr.extension == 255)
+ {
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ extended->name, &extended->declared_at);
+ return MATCH_ERROR;
+ }
+ sym->attr.extension = extended->attr.extension + 1;
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
st->n.sym = sym;
}
+ if (!sym->hash_value)
+ /* Set the hash for the compound name for this type. */
+ sym->hash_value = 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");
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
