locus old_loc;
int c;
- if (gfc_current_file->form == FORM_FIXED)
+ if (gfc_current_form == FORM_FIXED)
return MATCH_YES;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!gfc_is_whitespace (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
break;
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return (flag) ? MATCH_YES : MATCH_NO;
}
char c;
int i;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (!ISDIGIT (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!ISDIGIT (c))
}
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
*value = i;
return MATCH_YES;
match m;
int i;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
m = gfc_match_small_literal_int (&i);
if (m != MATCH_YES)
}
gfc_error ("Statement label at %C is out of range");
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_ERROR;
}
no_match = p->tag;
best_match = NULL;
- match_loc = *gfc_current_locus ();
+ match_loc = gfc_current_locus;
gfc_gobble_whitespace ();
if (*p->mp == ' ')
{
/* Space matches 1+ whitespace(s). */
- if ((gfc_current_file->form == FORM_FREE)
+ if ((gfc_current_form == FORM_FREE)
&& gfc_is_whitespace (c))
continue;
if (*p->mp == '\0')
{
/* Found a match. */
- match_loc = *gfc_current_locus ();
+ match_loc = gfc_current_locus;
best_match = p;
possibles--;
p->mp = NULL;
}
}
- gfc_set_locus (&match_loc);
+ gfc_current_locus = match_loc;
return (best_match == NULL) ? no_match : best_match->tag;
}
locus old_loc;
int i, c;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (!ISALPHA (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
return MATCH_ERROR;
}
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
}
while (ISALNUM (c)
|| (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_YES;
}
/* Match the start of an iterator without affecting the symbol
table. */
- start = *gfc_current_locus ();
+ start = gfc_current_locus;
m = gfc_match (" %n =", name);
- gfc_set_locus (&start);
+ gfc_current_locus = start;
if (m != MATCH_YES)
return MATCH_NO;
{
locus where;
- where = *gfc_current_locus ();
+ where = gfc_current_locus;
gfc_gobble_whitespace ();
if (gfc_next_char () == c)
return MATCH_YES;
- gfc_set_locus (&where);
+ gfc_current_locus = where;
return MATCH_NO;
}
void **vp;
const char *p;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
va_start (argp, target);
m = MATCH_NO;
matches = 0;
if (m != MATCH_YES)
{
/* Clean up after a failed match. */
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
va_start (argp, target);
p = target;
/*********************** Statement level matching **********************/
/* Matches the start of a program unit, which is the program keyword
- followed by an optional symbol. */
+ followed by an obligatory symbol. */
match
gfc_match_program (void)
gfc_symbol *sym;
match m;
- m = gfc_match_eos ();
- if (m == MATCH_YES)
- return m;
-
m = gfc_match ("% %s%t", &sym);
if (m == MATCH_NO)
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
m = gfc_match (" %v =", &lvalue);
return MATCH_YES;
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
gfc_free_expr (rvalue);
return m;
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
return MATCH_YES;
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
gfc_free_expr (rvalue);
return m;
if (n == MATCH_ERROR)
return n;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
m = gfc_match (" if ( %e", &expr);
if (m != MATCH_YES)
gfc_free_expr (expr);
gfc_undo_symbols ();
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
gfc_free_expr (expr);
gfc_undo_symbols ();
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
p = gfc_get_code ();
p->next = gfc_get_code ();
*p->next = new_st;
- p->next->loc = *gfc_current_locus ();
+ p->next->loc = gfc_current_locus;
p->expr = expr;
p->op = EXEC_IF;
gfc_st_label *label;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
label = NULL;
iter.var = iter.start = iter.end = iter.step = NULL;
/* The abortive DO WHILE may have done something to the symbol
table, so we start over: */
gfc_undo_symbols ();
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
gfc_match_label (); /* This won't error */
gfc_match (" do "); /* This will work */
/* build ' => NULL() ' */
e = gfc_get_expr ();
- e->where = *gfc_current_locus ();
+ e->where = gfc_current_locus;
e->expr_type = EXPR_NULL;
e->ts.type = BT_UNKNOWN;
{
gfc_expr *e;
match m;
+ gfc_compile_state s;
+
+ gfc_enclosing_unit (&s);
+ if (s == COMP_PROGRAM
+ && gfc_notify_std (GFC_STD_GNU, "RETURN statement in a main "
+ "program at %C is an extension.") == FAILURE)
+ return MATCH_ERROR;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
i = 0;
for (a = arglist; a; a = a->next)
if (a->expr == NULL)
- i = 1;
+ i = 1;
if (i)
{
c->expr->expr_type = EXPR_VARIABLE;
c->expr->symtree = select_st;
c->expr->ts = select_sym->ts;
- c->expr->where = *gfc_current_locus ();
+ c->expr->where = gfc_current_locus;
i = 0;
for (a = arglist; a; a = a->next)
}
-/* Match an IMPLICIT NONE statement. Actually, this statement is
- already matched in parse.c, or we would not end up here in the
- first place. So the only thing we need to check, is if there is
- trailing garbage. If not, the match is successful. */
+/* Given a name, return a pointer to the common head structure,
+ creating it if it does not exist. If FROM_MODULE is non-zero, we
+ mangle the name so that it doesn't interfere with commons defined
+ in the using namespace.
+ TODO: Add to global symbol tree. */
-match
-gfc_match_implicit_none (void)
+gfc_common_head *
+gfc_get_common (const char *name, int from_module)
{
+ gfc_symtree *st;
+ static int serial = 0;
+ char mangled_name[GFC_MAX_SYMBOL_LEN+1];
- return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
-}
-
-
-/* Match the letter range(s) of an IMPLICIT statement. */
-
-static match
-match_implicit_range (gfc_typespec * ts)
-{
- int c, c1, c2, inner;
- locus cur_loc;
-
- cur_loc = *gfc_current_locus ();
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if (c != '(')
+ if (from_module)
{
- gfc_error ("Missing character range in IMPLICIT at %C");
- goto bad;
+ /* A use associated common block is only needed to correctly layout
+ the variables it contains. */
+ snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+ st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
-
- inner = 1;
- while (inner)
+ else
{
- gfc_gobble_whitespace ();
- c1 = gfc_next_char ();
- if (!ISALPHA (c1))
- goto bad;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
-
- switch (c)
- {
- case ')':
- inner = 0; /* Fall through */
-
- case ',':
- c2 = c1;
- break;
-
- case '-':
- gfc_gobble_whitespace ();
- c2 = gfc_next_char ();
- if (!ISALPHA (c2))
- goto bad;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
-
- if ((c != ',') && (c != ')'))
- goto bad;
- if (c == ')')
- inner = 0;
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
- break;
-
- default:
- goto bad;
- }
-
- if (c1 > c2)
- {
- gfc_error ("Letters must be in alphabetic order in "
- "IMPLICIT statement at %C");
- goto bad;
- }
-
- /* See if we can add the newly matched range to the pending
- implicits from this IMPLICIT statement. We do not check for
- conflicts with whatever earlier IMPLICIT statements may have
- set. This is done when we've successfully finished matching
- the current one. */
- if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS)
- goto bad;
- }
-
- return MATCH_YES;
-
-bad:
- gfc_syntax_error (ST_IMPLICIT);
-
- gfc_set_locus (&cur_loc);
- return MATCH_ERROR;
-}
-
-
-/* Match an IMPLICIT statement, storing the types for
- gfc_set_implicit() if the statement is accepted by the parser.
- There is a strange looking, but legal syntactic construction
- possible. It looks like:
-
- IMPLICIT INTEGER (a-b) (c-d)
-
- This is legal if "a-b" is a constant expression that happens to
- equal one of the legal kinds for integers. The real problem
- happens with an implicit specification that looks like:
-
- IMPLICIT INTEGER (a-b)
-
- In this case, a typespec matcher that is "greedy" (as most of the
- matchers are) gobbles the character range as a kindspec, leaving
- nothing left. We therefore have to go a bit more slowly in the
- matching process by inhibiting the kindspec checking during
- typespec matching and checking for a kind later. */
-
-match
-gfc_match_implicit (void)
-{
- gfc_typespec ts;
- locus cur_loc;
- int c;
- match m;
-
- /* We don't allow empty implicit statements. */
- if (gfc_match_eos () == MATCH_YES)
- {
- gfc_error ("Empty IMPLICIT statement at %C");
- return MATCH_ERROR;
+ if (st == NULL)
+ st = gfc_new_symtree (&gfc_current_ns->common_root, name);
}
- /* First cleanup. */
- gfc_clear_new_implicit ();
-
- do
+ if (st->n.common == NULL)
{
- /* A basic type is mandatory here. */
- m = gfc_match_type_spec (&ts, 0);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
-
- cur_loc = *gfc_current_locus ();
- m = match_implicit_range (&ts);
-
- if (m == MATCH_YES)
- {
- /* Looks like we have the <TYPE> (<RANGE>). */
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c == '\n') || (c == ','))
- continue;
-
- gfc_set_locus (&cur_loc);
- }
-
- /* Last chance -- check <TYPE> (<KIND>) (<RANGE>). */
- m = gfc_match_kind_spec (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- {
- m = gfc_match_old_kind_spec (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
- }
-
- m = match_implicit_range (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c != '\n') && (c != ','))
- goto syntax;
-
+ st->n.common = gfc_get_common_head ();
+ st->n.common->where = gfc_current_locus;
+ strcpy (st->n.common->name, name);
}
- while (c == ',');
- /* All we need to now is try to merge the new implicit types back
- into the existing types. This will fail if another implicit
- type is already defined for a letter. */
- return (gfc_merge_new_implicit () == SUCCESS) ?
- MATCH_YES : MATCH_ERROR;
-
-syntax:
- gfc_syntax_error (ST_IMPLICIT);
-
-error:
- return MATCH_ERROR;
+ return st->n.common;
}
/* Match a common block name. */
static match
-match_common_name (gfc_symbol ** sym)
+match_common_name (char *name)
{
match m;
if (gfc_match_char ('/') == MATCH_NO)
- return MATCH_NO;
+ {
+ name[0] = '\0';
+ return MATCH_YES;
+ }
if (gfc_match_char ('/') == MATCH_YES)
{
- *sym = NULL;
+ name[0] = '\0';
return MATCH_YES;
}
- m = gfc_match_symbol (sym, 0);
+ m = gfc_match_name (name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
match
gfc_match_common (void)
{
- gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common;
+ gfc_symbol *sym, **head, *tail, *old_blank_common;
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *t;
gfc_array_spec *as;
match m;
- old_blank_common = gfc_current_ns->blank_common;
+ old_blank_common = gfc_current_ns->blank_common.head;
if (old_blank_common)
{
while (old_blank_common->common_next)
old_blank_common = old_blank_common->common_next;
}
- common_name = NULL;
as = NULL;
if (gfc_match_eos () == MATCH_YES)
for (;;)
{
- m = match_common_name (&common_name);
+ m = match_common_name (name);
if (m == MATCH_ERROR)
goto cleanup;
- if (common_name == NULL)
- head = &gfc_current_ns->blank_common;
+ if (name[0] == '\0')
+ {
+ t = &gfc_current_ns->blank_common;
+ if (t->head == NULL)
+ t->where = gfc_current_locus;
+ head = &t->head;
+ }
else
{
- head = &common_name->common_head;
-
- if (!common_name->attr.common
- && gfc_add_common (&common_name->attr, NULL) == FAILURE)
- goto cleanup;
+ t = gfc_get_common (name, 0);
+ head = &t->head;
}
if (*head == NULL)
}
/* Grab the list of symbols. */
+ if (gfc_match_eos () == MATCH_YES)
+ goto done;
+
for (;;)
{
m = gfc_match_symbol (&sym, 0);
goto cleanup;
}
+ if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
+ goto cleanup;
+
+ if (sym->value != NULL
+ && (name[0] == '\0' || !sym->attr.data))
+ {
+ if (name[0] == '\0')
+ gfc_error ("Previously initialized symbol '%s' in "
+ "blank COMMON block at %C", sym->name);
+ else
+ gfc_error ("Previously initialized symbol '%s' in "
+ "COMMON block '%s' at %C", sym->name, name);
+ goto cleanup;
+ }
+
if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
goto cleanup;
if (old_blank_common)
old_blank_common->common_next = NULL;
else
- gfc_current_ns->blank_common = NULL;
+ gfc_current_ns->blank_common.head = NULL;
gfc_free_array_spec (as);
return MATCH_ERROR;
}
return MATCH_YES;
}
- m = gfc_match (" %n%t", name);
+ m = gfc_match ("% %n%t", name);
if (m != MATCH_YES)
return MATCH_ERROR;
var_element (gfc_data_variable * new)
{
match m;
+ gfc_symbol *sym;
memset (new, '\0', sizeof (gfc_data_variable));
if (m != MATCH_YES)
return m;
- if (new->expr->symtree->n.sym->value != NULL)
+ sym = new->expr->symtree->n.sym;
+
+ if(sym->value != NULL)
{
gfc_error ("Variable '%s' at %C already has an initialization",
- new->expr->symtree->n.sym->name);
+ sym->name);
return MATCH_ERROR;
}
- new->expr->symtree->n.sym->attr.data = 1;
+#if 0 // TODO: Find out where to move this message
+ if (sym->attr.in_common)
+ /* See if sym is in the blank common block. */
+ for (t = &sym->ns->blank_common; t; t = t->common_next)
+ if (sym == t->head)
+ {
+ gfc_error ("DATA statement at %C may not initialize variable "
+ "'%s' from blank COMMON", sym->name);
+ return MATCH_ERROR;
+ }
+#endif
+
+ if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
+ return MATCH_ERROR;
+
return MATCH_YES;
}
if (gfc_find_symbol (name, NULL, 1, &sym))
return MATCH_ERROR;
- if (sym == NULL || sym->attr.flavor != FL_PARAMETER)
+ if (sym == NULL
+ || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
+ else if (sym->attr.flavor == FL_DERIVED)
+ return gfc_match_structure_constructor (sym, result);
*result = gfc_copy_expr (sym->value);
return MATCH_YES;
for (;;)
{
new = gfc_get_data ();
- new->where = *gfc_current_locus ();
+ new->where = gfc_current_locus;
m = top_var_list (new);
if (m != MATCH_YES)
match m;
c = gfc_get_case ();
- c->where = *gfc_current_locus ();
+ c->where = gfc_current_locus;
if (gfc_match_char (':') == MATCH_YES)
{
- m = gfc_match_expr (&c->high);
+ m = gfc_match_init_expr (&c->high);
if (m == MATCH_NO)
goto need_expr;
if (m == MATCH_ERROR)
else
{
- m = gfc_match_expr (&c->low);
+ m = gfc_match_init_expr (&c->low);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
c->high = c->low;
else
{
- m = gfc_match_expr (&c->high);
+ m = gfc_match_init_expr (&c->high);
if (m == MATCH_ERROR)
goto cleanup;
/* MATCH_NO is fine. It's OK if nothing is there! */
return MATCH_YES;
need_expr:
- gfc_error ("Expected expression in CASE at %C");
+ gfc_error ("Expected initialization expression in CASE at %C");
cleanup:
free_case (c);
new_st.op = EXEC_SELECT;
c = gfc_get_case ();
- c->where = *gfc_current_locus ();
+ c->where = gfc_current_locus;
new_st.ext.case_list = c;
return MATCH_YES;
}
locus where;
match m;
- where = *gfc_current_locus ();
+ where = gfc_current_locus;
iter = gfc_getmem (sizeof (gfc_forall_iterator));
m = gfc_match_variable (&iter->var, 0);
m = MATCH_ERROR;
cleanup:
- gfc_set_locus (&where);
+ gfc_current_locus = where;
gfc_free_forall_iterator (iter);
return m;
}
OSDN Git Service
