/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
2010 Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "match.h"
#include "parse.h"
+int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
bool gfc_matching_prefix = false;
gfc_match_parens (void)
{
locus old_loc, where;
- int count, instring;
+ int count;
+ gfc_instring instring;
gfc_char_t c, quote;
old_loc = gfc_current_locus;
count = 0;
- instring = 0;
+ instring = NONSTRING;
quote = ' ';
for (;;)
if (quote == ' ' && ((c == '\'') || (c == '"')))
{
quote = c;
- instring = 1;
+ instring = INSTRING_WARN;
continue;
}
if (quote != ' ' && c == quote)
{
quote = ' ';
- instring = 0;
+ instring = NONSTRING;
continue;
}
m = MATCH_YES;
- switch ((c = gfc_next_char_literal (1)))
+ switch ((c = gfc_next_char_literal (INSTRING_WARN)))
{
case 'a':
*res = '\a';
{
char buf[2] = { '\0', '\0' };
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (INSTRING_WARN);
if (!gfc_wide_fits_in_byte (c)
|| !gfc_check_digit ((unsigned char) c, 16))
return MATCH_NO;
/* Get the next char (first possible char of name) and see if
it's valid for C (either a letter or an underscore). */
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (INSTRING_WARN);
/* If the user put nothing expect spaces between the quotes, it is valid
and simply means there is no name= specifier and the name is the fortran
old_loc = gfc_current_locus;
/* Get next char; param means we're in a string. */
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_');
buffer[i] = '\0';
locus start;
match m;
+ e1 = e2 = e3 = NULL;
+
/* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
if (m != MATCH_YES)
return MATCH_NO;
- gfc_match_char ('=');
-
- e1 = e2 = e3 = NULL;
-
- if (var->ref != NULL)
+ /* F2008, C617 & C565. */
+ if (var->symtree->n.sym->attr.codimension)
{
- gfc_error ("Loop variable at %C cannot be a sub-component");
+ gfc_error ("Loop variable at %C cannot be a coarray");
goto cleanup;
}
- if (var->symtree->n.sym->attr.intent == INTENT_IN)
+ if (var->ref != NULL)
{
- gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
- var->symtree->n.sym->name);
+ gfc_error ("Loop variable at %C cannot be a sub-component");
goto cleanup;
}
+ gfc_match_char ('=');
+
var->symtree->n.sym->attr.implied_index = 1;
m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
if (gfc_match_char (',') != MATCH_YES)
{
- e3 = gfc_int_expr (1);
+ e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
goto done;
}
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
+ gfc_matching_ptr_assignment = 0;
gfc_matching_procptr_assignment = 0;
m = gfc_match (" %v =>", &lvalue);
if (lvalue->symtree->n.sym->attr.proc_pointer
|| gfc_is_proc_ptr_comp (lvalue, NULL))
gfc_matching_procptr_assignment = 1;
+ else
+ gfc_matching_ptr_assignment = 1;
m = gfc_match (" %e%t", &rvalue);
+ gfc_matching_ptr_assignment = 0;
gfc_matching_procptr_assignment = 0;
if (m != MATCH_YES)
goto cleanup;
== FAILURE)
return MATCH_ERROR;
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Nested CRITICAL block at %C");
}
+/* Match an ASSOCIATE statement. */
+
+match
+gfc_match_associate (void)
+{
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" associate") != MATCH_YES)
+ return MATCH_NO;
+
+ /* Match the association list. */
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Expected association list at %C");
+ return MATCH_ERROR;
+ }
+ new_st.ext.block.assoc = NULL;
+ while (true)
+ {
+ gfc_association_list* newAssoc = gfc_get_association_list ();
+ gfc_association_list* a;
+
+ /* Match the next association. */
+ if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
+ != MATCH_YES)
+ {
+ gfc_error ("Expected association at %C");
+ goto assocListError;
+ }
+ newAssoc->where = gfc_current_locus;
+
+ /* Check that the current name is not yet in the list. */
+ for (a = new_st.ext.block.assoc; a; a = a->next)
+ if (!strcmp (a->name, newAssoc->name))
+ {
+ gfc_error ("Duplicate name '%s' in association at %C",
+ newAssoc->name);
+ goto assocListError;
+ }
+
+ /* The target expression must not be coindexed. */
+ if (gfc_is_coindexed (newAssoc->target))
+ {
+ gfc_error ("Association target at %C must not be coindexed");
+ goto assocListError;
+ }
+
+ /* The `variable' field is left blank for now; because the target is not
+ yet resolved, we can't use gfc_has_vector_subscript to determine it
+ for now. This is set during resolution. */
+
+ /* Put it into the list. */
+ newAssoc->next = new_st.ext.block.assoc;
+ new_st.ext.block.assoc = newAssoc;
+
+ /* Try next one or end if closing parenthesis is found. */
+ gfc_gobble_whitespace ();
+ if (gfc_peek_char () == ')')
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Expected ')' or ',' at %C");
+ return MATCH_ERROR;
+ }
+
+ continue;
+
+assocListError:
+ gfc_free (newAssoc);
+ goto error;
+ }
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ /* This should never happen as we peek above. */
+ gcc_unreachable ();
+ }
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after ASSOCIATE statement at %C");
+ goto error;
+ }
+
+ return MATCH_YES;
+
+error:
+ gfc_free_association_list (new_st.ext.block.assoc);
+ return MATCH_ERROR;
+}
+
+
/* Match a DO statement. */
match
if (gfc_match_eos () == MATCH_YES)
{
- iter.end = gfc_logical_expr (1, NULL);
+ iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
new_st.op = EXEC_DO_WHILE;
goto done;
}
gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
+ int cnt;
if (gfc_match_eos () == MATCH_YES)
sym = NULL;
else
{
- m = gfc_match ("% %s%t", &sym);
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symtree* stree;
+
+ m = gfc_match ("% %n%t", name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
return MATCH_ERROR;
}
+ /* Find the corresponding symbol. If there's a BLOCK statement
+ between here and the label, it is not in gfc_current_ns but a parent
+ namespace! */
+ stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
+ if (!stree)
+ {
+ gfc_error ("Name '%s' in %s statement at %C is unknown",
+ name, gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+
+ sym = stree->n.sym;
if (sym->attr.flavor != FL_LABEL)
{
- gfc_error ("Name '%s' in %s statement at %C is not a loop name",
- sym->name, gfc_ascii_statement (st));
+ gfc_error ("Name '%s' in %s statement at %C is not a construct name",
+ name, gfc_ascii_statement (st));
return MATCH_ERROR;
}
}
- /* Find the loop mentioned specified by the label (or lack of a label). */
+ /* Find the loop specified by the label (or lack of a label). */
for (o = NULL, p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
- break;
- else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+ if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
else if (p->state == COMP_CRITICAL)
{
gfc_ascii_statement (st));
return MATCH_ERROR;
}
+ else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
+ break;
if (p == NULL)
{
if (sym == NULL)
- gfc_error ("%s statement at %C is not within a loop",
+ gfc_error ("%s statement at %C is not within a construct",
gfc_ascii_statement (st));
else
- gfc_error ("%s statement at %C is not within loop '%s'",
+ gfc_error ("%s statement at %C is not within construct '%s'",
gfc_ascii_statement (st), sym->name);
return MATCH_ERROR;
}
+ /* Special checks for EXIT from non-loop constructs. */
+ switch (p->state)
+ {
+ case COMP_DO:
+ break;
+
+ case COMP_CRITICAL:
+ /* This is already handled above. */
+ gcc_unreachable ();
+
+ case COMP_ASSOCIATE:
+ case COMP_BLOCK:
+ case COMP_IF:
+ case COMP_SELECT:
+ case COMP_SELECT_TYPE:
+ gcc_assert (sym);
+ if (op == EXEC_CYCLE)
+ {
+ gfc_error ("CYCLE statement at %C is not applicable to non-loop"
+ " construct '%s'", sym->name);
+ return MATCH_ERROR;
+ }
+ gcc_assert (op == EXEC_EXIT);
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
+ " do-construct-name at %C") == FAILURE)
+ return MATCH_ERROR;
+ break;
+
+ default:
+ gfc_error ("%s statement at %C is not applicable to construct '%s'",
+ gfc_ascii_statement (st), sym->name);
+ return MATCH_ERROR;
+ }
+
if (o != NULL)
{
gfc_error ("%s statement at %C leaving OpenMP structured block",
gfc_ascii_statement (st));
return MATCH_ERROR;
}
- else if (st == ST_EXIT
- && p->previous != NULL
- && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
- && (p->previous->head->op == EXEC_OMP_DO
- || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
- {
- gcc_assert (p->previous->head->next != NULL);
- gcc_assert (p->previous->head->next->op == EXEC_DO
- || p->previous->head->next->op == EXEC_DO_WHILE);
- gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
- return MATCH_ERROR;
+
+ for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
+ o = o->previous;
+ if (cnt > 0
+ && o != NULL
+ && o->state == COMP_OMP_STRUCTURED_BLOCK
+ && (o->head->op == EXEC_OMP_DO
+ || o->head->op == EXEC_OMP_PARALLEL_DO))
+ {
+ int collapse = 1;
+ gcc_assert (o->head->next != NULL
+ && (o->head->next->op == EXEC_DO
+ || o->head->next->op == EXEC_DO_WHILE)
+ && o->previous != NULL
+ && o->previous->tail->op == o->head->op);
+ if (o->previous->tail->ext.omp_clauses != NULL
+ && o->previous->tail->ext.omp_clauses->collapse > 1)
+ collapse = o->previous->tail->ext.omp_clauses->collapse;
+ if (st == ST_EXIT && cnt <= collapse)
+ {
+ gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+ return MATCH_ERROR;
+ }
+ if (st == ST_CYCLE && cnt < collapse)
+ {
+ gfc_error ("CYCLE statement at %C to non-innermost collapsed"
+ " !$OMP DO loop");
+ return MATCH_ERROR;
+ }
}
- /* Save the first statement in the loop - needed by the backend. */
- new_st.ext.whichloop = p->head;
+ /* Save the first statement in the construct - needed by the backend. */
+ new_st.ext.which_construct = p->construct;
new_st.op = op;
static match
gfc_match_stopcode (gfc_statement st)
{
- int stop_code;
gfc_expr *e;
match m;
- int cnt;
- stop_code = -1;
e = NULL;
if (gfc_match_eos () != MATCH_YES)
{
- m = gfc_match_small_literal_int (&stop_code, &cnt);
+ m = gfc_match_init_expr (&e);
if (m == MATCH_ERROR)
goto cleanup;
-
- if (m == MATCH_YES && cnt > 5)
- {
- gfc_error ("Too many digits in STOP code at %C");
- goto cleanup;
- }
-
if (m == MATCH_NO)
- {
- /* Try a character constant. */
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
- goto syntax;
- }
+ goto syntax;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Image control statement STOP at %C in CRITICAL block");
- return MATCH_ERROR;
+ goto cleanup;
+ }
+
+ if (e != NULL)
+ {
+ if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
+ {
+ gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
+ &e->where);
+ goto cleanup;
+ }
+
+ if (e->rank != 0)
+ {
+ gfc_error ("STOP code at %L must be scalar",
+ &e->where);
+ goto cleanup;
+ }
+
+ if (e->ts.type == BT_CHARACTER
+ && e->ts.kind != gfc_default_character_kind)
+ {
+ gfc_error ("STOP code at %L must be default character KIND=%d",
+ &e->where, (int) gfc_default_character_kind);
+ goto cleanup;
+ }
+
+ if (e->ts.type == BT_INTEGER
+ && e->ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("STOP code at %L must be default integer KIND=%d",
+ &e->where, (int) gfc_default_integer_kind);
+ goto cleanup;
+ }
}
switch (st)
}
new_st.expr1 = e;
- new_st.ext.stop_code = stop_code;
+ new_st.ext.stop_code = -1;
return MATCH_YES;
== FAILURE)
return MATCH_ERROR;
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Image control statement SYNC at %C in CRITICAL block");
}
cp = gfc_get_case ();
- cp->low = cp->high = gfc_int_expr (i++);
+ cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, i++);
tail->op = EXEC_SELECT;
tail->ext.case_list = cp;
static match
match_derived_type_spec (gfc_typespec *ts)
{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
gfc_symbol *derived;
- old_locus = gfc_current_locus;
+ old_locus = gfc_current_locus;
- if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+ if (gfc_match ("%n", name) != MATCH_YES)
{
- if (derived->attr.flavor == FL_DERIVED)
- {
- ts->type = BT_DERIVED;
- ts->u.derived = derived;
- return MATCH_YES;
- }
- else
- {
- /* Enforce F03:C476. */
- gfc_error ("'%s' at %L is not an accessible derived type",
- derived->name, &gfc_current_locus);
- return MATCH_ERROR;
- }
+ gfc_current_locus = old_locus;
+ return MATCH_NO;
+ }
+
+ gfc_find_symbol (name, NULL, 1, &derived);
+
+ if (derived && derived->attr.flavor == FL_DERIVED)
+ {
+ ts->type = BT_DERIVED;
+ ts->u.derived = derived;
+ return MATCH_YES;
}
gfc_current_locus = old_locus;
gfc_match_decl_type_spec() from decl.c, with the following exceptions:
It only includes the intrinsic types from the Fortran 2003 standard
(thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
- the implicit_flag is not needed, so it was removed. Derived types are
+ the implicit_flag is not needed, so it was removed. Derived types are
identified by their name alone. */
static match
locus old_locus;
gfc_clear_ts (ts);
+ gfc_gobble_whitespace ();
old_locus = gfc_current_locus;
+ if (match_derived_type_spec (ts) == MATCH_YES)
+ {
+ /* Enforce F03:C401. */
+ if (ts->u.derived->attr.abstract)
+ {
+ gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+ ts->u.derived->name, &old_locus);
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+ }
+
if (gfc_match ("integer") == MATCH_YES)
{
ts->type = BT_INTEGER;
if (gfc_match ("character") == MATCH_YES)
{
ts->type = BT_CHARACTER;
- goto char_selector;
+
+ m = gfc_match_char_spec (ts);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES;
+
+ return m;
}
if (gfc_match ("logical") == MATCH_YES)
goto kind_selector;
}
- m = match_derived_type_spec (ts);
- if (m == MATCH_YES)
- {
- old_locus = gfc_current_locus;
- if (gfc_match (" :: ") != MATCH_YES)
- return MATCH_ERROR;
- gfc_current_locus = old_locus;
- /* Enfore F03:C401. */
- if (ts->u.derived->attr.abstract)
- {
- gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
- ts->u.derived->name, &old_locus);
- return MATCH_ERROR;
- }
- return MATCH_YES;
- }
- else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
- return MATCH_ERROR;
-
/* If a type is not matched, simply return MATCH_NO. */
gfc_current_locus = old_locus;
return MATCH_NO;
m = MATCH_YES; /* No kind specifier found. */
return m;
-
-char_selector:
-
- m = gfc_match_char_spec (ts);
-
- if (m == MATCH_NO)
- m = MATCH_YES; /* No kind specifier found. */
-
- return m;
}
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp, *source;
+ gfc_expr *stat, *errmsg, *tmp, *source, *mold;
gfc_typespec ts;
gfc_symbol *sym;
match m;
- locus old_locus;
- bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
+ locus old_locus, deferred_locus;
+ bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
head = tail = NULL;
- stat = errmsg = source = tmp = NULL;
- saw_stat = saw_errmsg = saw_source = false;
+ stat = errmsg = source = mold = tmp = NULL;
+ saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
else if (m == MATCH_NO)
- ts.type = BT_UNKNOWN;
+ {
+ char name[GFC_MAX_SYMBOL_LEN + 3];
+
+ if (gfc_match ("%n :: ", name) == MATCH_YES)
+ {
+ gfc_error ("Error in type-spec at %L", &old_locus);
+ goto cleanup;
+ }
+
+ ts.type = BT_UNKNOWN;
+ }
else
{
if (gfc_match (" :: ") == MATCH_YES)
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
"ALLOCATE at %L", &old_locus) == FAILURE)
goto cleanup;
+
+ if (ts.deferred)
+ {
+ gfc_error ("Type-spec at %L cannot contain a deferred "
+ "type parameter", &old_locus);
+ goto cleanup;
+ }
}
else
{
goto cleanup;
}
+ if (tail->expr->ts.deferred)
+ {
+ saw_deferred = true;
+ deferred_locus = tail->expr->where;
+ }
+
/* The ALLOCATE statement had an optional typespec. Check the
constraints. */
if (ts.type != BT_UNKNOWN)
&& (tail->expr->ref->type == REF_COMPONENT
|| tail->expr->ref->type == REF_ARRAY));
if (sym && sym->ts.type == BT_CLASS)
- b2 = !(sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer);
+ b2 = !(CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer);
else
b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
|| sym->attr.proc_pointer);
|| sym->ns->proc_name->attr.proc_pointer);
if (b1 && b2 && !b3)
{
- gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
- "or an allocatable variable");
+ gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
+ "or an allocatable variable", &tail->expr->where);
goto cleanup;
}
}
stat = tmp;
+ tmp = NULL;
saw_stat = true;
if (gfc_check_do_variable (stat->symtree))
}
errmsg = tmp;
+ tmp = NULL;
saw_errmsg = true;
if (gfc_match_char (',') == MATCH_YES)
}
source = tmp;
+ tmp = NULL;
saw_source = true;
if (gfc_match_char (',') == MATCH_YES)
goto alloc_opt_list;
}
+ m = gfc_match (" mold = %e", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ /* Check F08:C636. */
+ if (saw_mold)
+ {
+ gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+
+ /* Check F08:C637. */
+ if (ts.type != BT_UNKNOWN)
+ {
+ gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
+ &tmp->where, &old_locus);
+ goto cleanup;
+ }
+
+ mold = tmp;
+ tmp = NULL;
+ saw_mold = true;
+ mold->mold = 1;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
gfc_gobble_whitespace ();
if (gfc_peek_char () == ')')
break;
}
-
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
+ /* Check F08:C637. */
+ if (source && mold)
+ {
+ gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
+ &mold->where, &source->where);
+ goto cleanup;
+ }
+
+ /* Check F03:C623, */
+ if (saw_deferred && ts.type == BT_UNKNOWN && !source)
+ {
+ gfc_error ("Allocate-object at %L with a deferred type parameter "
+ "requires either a type-spec or SOURCE tag", &deferred_locus);
+ goto cleanup;
+ }
+
new_st.op = EXEC_ALLOCATE;
new_st.expr1 = stat;
new_st.expr2 = errmsg;
- new_st.expr3 = source;
+ if (source)
+ new_st.expr3 = source;
+ else
+ new_st.expr3 = mold;
new_st.ext.alloc.list = head;
new_st.ext.alloc.ts = ts;
gfc_free_expr (errmsg);
gfc_free_expr (source);
gfc_free_expr (stat);
- gfc_free_expr (tmp);
+ gfc_free_expr (mold);
+ if (tmp && tmp->expr_type) gfc_free_expr (tmp);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
if (gfc_check_do_variable (p->symtree))
goto cleanup;
- if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
- {
- gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
- goto cleanup;
- }
-
/* build ' => NULL() '. */
- e = gfc_get_expr ();
- e->where = gfc_current_locus;
- e->expr_type = EXPR_NULL;
- e->ts.type = BT_UNKNOWN;
+ e = gfc_get_null_expr (&gfc_current_locus);
/* Chain to list. */
if (tail == NULL)
&& (tail->expr->ref->type == REF_COMPONENT
|| tail->expr->ref->type == REF_ARRAY));
if (sym && sym->ts.type == BT_CLASS)
- b2 = !(sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer);
+ b2 = !(CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer);
else
b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
|| sym->attr.proc_pointer);
c->op = EXEC_SELECT;
new_case = gfc_get_case ();
- new_case->high = new_case->low = gfc_int_expr (i);
+ new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
+ new_case->low = new_case->high;
c->ext.case_list = new_case;
c->next = gfc_get_code ();
do this. */
void
-gfc_free_equiv (gfc_equiv *eq)
+gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
{
- if (eq == NULL)
+ if (eq == stop)
return;
gfc_free_equiv (eq->eq);
- gfc_free_equiv (eq->next);
+ gfc_free_equiv_until (eq->next, stop);
gfc_free_expr (eq->expr);
gfc_free (eq);
}
+void
+gfc_free_equiv (gfc_equiv *eq)
+{
+ gfc_free_equiv_until (eq, NULL);
+}
+
+
/* Match an EQUIVALENCE statement. */
match
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
+ if (!ts)
+ {
+ select_type_stack->tmp = NULL;
+ return;
+ }
+
if (!gfc_type_is_extensible (ts->u.derived))
return;
if (ts->type == BT_CLASS)
- sprintf (name, "tmp$class$%s", ts->u.derived->name);
+ sprintf (name, "__tmp_class_%s", ts->u.derived->name);
else
- sprintf (name, "tmp$type$%s", ts->u.derived->name);
+ sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
gfc_set_sym_referenced (tmp->n.sym);
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
- &tmp->n.sym->as);
+ &tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}
+ tmp->n.sym->attr.select_type_temporary = 1;
+
+ /* Add an association for it, so the rest of the parser knows it is
+ an associate-name. The target will be set during resolution. */
+ tmp->n.sym->assoc = gfc_get_association_list ();
+ tmp->n.sym->assoc->dangling = 1;
+ tmp->n.sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
expr1 = gfc_get_expr();
expr1->expr_type = EXPR_VARIABLE;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
- return MATCH_ERROR;
- expr1->symtree->n.sym->ts = expr2->ts;
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (expr2->ts.type == BT_UNKNOWN)
+ expr1->symtree->n.sym->attr.untyped = 1;
+ else
+ expr1->symtree->n.sym->ts = expr2->ts;
+ expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
expr1->symtree->n.sym->attr.referenced = 1;
expr1->symtree->n.sym->attr.class_ok = 1;
}
{
m = gfc_match (" %e ", &expr1);
if (m != MATCH_YES)
- return m;
+ goto cleanup;
}
m = gfc_match (" )%t");
if (m != MATCH_YES)
- return m;
+ goto cleanup;
/* Check for F03:C811. */
if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
{
gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"use associate-name=>");
- return MATCH_ERROR;
- }
-
- /* Check for F03:C813. */
- if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
- {
- gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
- "at %C");
- return MATCH_ERROR;
+ m = MATCH_ERROR;
+ goto cleanup;
}
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
- new_st.ext.ns = gfc_current_ns;
+ new_st.ext.block.ns = gfc_current_ns;
select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
+
+cleanup:
+ gfc_current_ns = gfc_current_ns->parent;
+ return m;
}
c->where = gfc_current_locus;
c->ts.type = BT_UNKNOWN;
new_st.ext.case_list = c;
+ select_type_set_tmp (NULL);
return MATCH_YES;
}
goto cleanup;
if (gfc_match_char (':') == MATCH_NO)
- iter->stride = gfc_int_expr (1);
+ iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
else
{
m = gfc_match_expr (&iter->stride);
OSDN Git Service
