/* Declaration statement matcher
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
add_init_expr_to_sym (const char *name, gfc_expr ** initp,
locus * var_locus)
{
- int i;
symbol_attribute attr;
gfc_symbol *sym;
gfc_expr *init;
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
- for (i = 0; i < sym->attr.dimension; i++)
- {
- if (sym->as->lower[i] == NULL
- || sym->as->lower[i]->expr_type != EXPR_CONSTANT
- || sym->as->upper[i] == NULL
- || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Array '%s' at %C cannot have initializer",
- sym->name);
- return FAILURE;
- }
- }
-
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
init->rank = sym->as->rank;
return MATCH_ERROR;
e = gfc_get_expr ();
- e->where = *gfc_current_locus ();
+ e->where = gfc_current_locus;
e->expr_type = EXPR_NULL;
e->ts.type = BT_UNKNOWN;
}
-/* Get an expression for a default initializer. */
-static gfc_expr *
-default_initializer (void)
-{
- gfc_constructor *tail;
- gfc_expr *init;
- gfc_component *c;
-
- init = NULL;
-
- /* First see if we have a default initializer. */
- for (c = current_ts.derived->components; c; c = c->next)
- {
- if (c->initializer && init == NULL)
- init = gfc_get_expr ();
- }
-
- if (init == NULL)
- return NULL;
-
- init->expr_type = EXPR_STRUCTURE;
- init->ts = current_ts;
- init->where = current_ts.derived->declared_at;
- tail = NULL;
- for (c = current_ts.derived->components; c; c = c->next)
- {
- if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- if (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
- }
- return init;
-}
-
-
/* Match a variable name with an optional initializer. When this
subroutine is called, a variable is expected to be parsed next.
Depending on what is happening at the moment, updates either the
if (m != MATCH_YES)
goto cleanup;
- var_locus = *gfc_current_locus ();
+ var_locus = gfc_current_locus;
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as);
}
}
- if (current_ts.type == BT_DERIVED && !initializer)
- {
- initializer = default_initializer ();
- }
-
- /* Add the initializer. Note that it is fine if &initializer is
+ /* Add the initializer. Note that it is fine if initializer is
NULL here, because we sometimes also need to check if a
declaration *must* have an initialization expression. */
if (gfc_current_state () != COMP_DERIVED)
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
- t = build_struct (name, cl, &initializer, &as);
+ {
+ if (current_ts.type == BT_DERIVED && !initializer)
+ initializer = gfc_default_initializer (¤t_ts);
+ t = build_struct (name, cl, &initializer, &as);
+ }
m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
m = MATCH_NO;
e = NULL;
- where = *gfc_current_locus ();
+ where = gfc_current_locus;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
no_match:
gfc_free_expr (e);
- gfc_set_locus (&where);
+ gfc_current_locus = where;
return m;
}
to the matched specification. This is necessary for FUNCTION and
IMPLICIT statements.
- If kind_flag is nonzero, then we check for the optional kind
- specification. Not doing so is needed for matching an IMPLICIT
+ If implicit_flag is nonzero, then we don't check for the optional
+ kind specification. Not doing so is needed for matching an IMPLICIT
statement correctly. */
-match
-gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
+static match
+match_type_spec (gfc_typespec * ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
+ int c;
gfc_clear_ts (ts);
if (gfc_match (" character") == MATCH_YES)
{
ts->type = BT_CHARACTER;
- return match_char_spec (ts);
+ if (implicit_flag == 0)
+ return match_char_spec (ts);
+ else
+ return MATCH_YES;
}
if (gfc_match (" real") == MATCH_YES)
get_kind:
/* For all types except double, derived and character, look for an
optional kind specifier. MATCH_NO is actually OK at this point. */
- if (kind_flag == 0)
+ if (implicit_flag == 1)
return MATCH_YES;
+ if (gfc_current_form == FORM_FREE)
+ {
+ c = gfc_peek_char();
+ if (!gfc_is_whitespace(c) && c != '*' && c != '('
+ && c != ':' && c != ',')
+ return MATCH_NO;
+ }
+
m = gfc_match_kind_spec (ts);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
}
+/* 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. */
+
+match
+gfc_match_implicit_none (void)
+{
+
+ return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+}
+
+
+/* Match the letter range(s) of an IMPLICIT statement. */
+
+static match
+match_implicit_range (void)
+{
+ int c, c1, c2, inner;
+ locus cur_loc;
+
+ cur_loc = gfc_current_locus;
+
+ gfc_gobble_whitespace ();
+ c = gfc_next_char ();
+ if (c != '(')
+ {
+ gfc_error ("Missing character range in IMPLICIT at %C");
+ goto bad;
+ }
+
+ inner = 1;
+ while (inner)
+ {
+ 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;
+
+ 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) != SUCCESS)
+ goto bad;
+ }
+
+ return MATCH_YES;
+
+bad:
+ gfc_syntax_error (ST_IMPLICIT);
+
+ gfc_current_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;
+ }
+
+ do
+ {
+ /* First cleanup. */
+ gfc_clear_new_implicit ();
+
+ /* A basic type is mandatory here. */
+ m = match_type_spec (&ts, 1);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ cur_loc = gfc_current_locus;
+ m = match_implicit_range ();
+
+ if (m == MATCH_YES)
+ {
+ /* We may have <TYPE> (<RANGE>). */
+ gfc_gobble_whitespace ();
+ c = gfc_next_char ();
+ if ((c == '\n') || (c == ','))
+ {
+ /* Check for CHARACTER with no length parameter. */
+ if (ts.type == BT_CHARACTER && !ts.cl)
+ {
+ ts.kind = gfc_default_character_kind ();
+ ts.cl = gfc_get_charlen ();
+ ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = ts.cl;
+ ts.cl->length = gfc_int_expr (1);
+ }
+
+ /* Record the Successful match. */
+ if (gfc_merge_new_implicit (&ts) != SUCCESS)
+ return MATCH_ERROR;
+ continue;
+ }
+
+ gfc_current_locus = cur_loc;
+ }
+
+ /* Discard the (incorrectly) matched range. */
+ gfc_clear_new_implicit ();
+
+ /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
+ if (ts.type == BT_CHARACTER)
+ m = match_char_spec (&ts);
+ else
+ {
+ m = gfc_match_kind_spec (&ts);
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_old_kind_spec (&ts);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ goto syntax;
+ }
+ }
+ if (m == MATCH_ERROR)
+ goto error;
+
+ m = match_implicit_range ();
+ 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;
+
+ if (gfc_merge_new_implicit (&ts) != SUCCESS)
+ return MATCH_ERROR;
+ }
+ while (c == ',');
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_IMPLICIT);
+
+error:
+ return MATCH_ERROR;
+}
+
+
/* Matches an attribute specification including array specs. If
successful, leaves the variables current_attr and current_as
holding the specification. Also sets the colon_seen variable for
try t;
gfc_clear_attr (¤t_attr);
- start = *gfc_current_locus ();
+ start = gfc_current_locus;
current_as = NULL;
colon_seen = 0;
break;
seen[d]++;
- seen_at[d] = *gfc_current_locus ();
+ seen_at[d] = gfc_current_locus;
if (d == DECL_DIMENSION)
{
return MATCH_YES;
cleanup:
- gfc_set_locus (&start);
+ gfc_current_locus = start;
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
gfc_symbol *sym;
match m;
- m = gfc_match_type_spec (¤t_ts, 1);
+ m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
loop:
if (!seen_type && ts != NULL
- && gfc_match_type_spec (ts, 1) == MATCH_YES
+ && match_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
gfc_clear_ts (¤t_ts);
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
m = match_prefix (¤t_ts);
if (m != MATCH_YES)
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return m;
}
if (gfc_match ("function% %n", name) != MATCH_YES)
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
return MATCH_YES;
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return m;
}
}
+/* Return nonzero if we're currenly compiling a contained procedure. */
+
+static int
+contained_procedure (void)
+{
+ gfc_state_data *s;
+
+ for (s=gfc_state_stack; s; s=s->previous)
+ if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
+ && s->previous != NULL
+ && s->previous->state == COMP_CONTAINS)
+ return 1;
+
+ return 0;
+}
+
/* 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. */
locus old_loc;
const char *block_name;
const char *target;
+ int eos_ok;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
if (gfc_match ("end") != MATCH_YES)
return MATCH_NO;
case COMP_PROGRAM:
*st = ST_END_PROGRAM;
target = " program";
+ eos_ok = 1;
break;
case COMP_SUBROUTINE:
*st = ST_END_SUBROUTINE;
target = " subroutine";
+ eos_ok = !contained_procedure ();
break;
case COMP_FUNCTION:
*st = ST_END_FUNCTION;
target = " function";
+ eos_ok = !contained_procedure ();
break;
case COMP_BLOCK_DATA:
*st = ST_END_BLOCK_DATA;
target = " block data";
+ eos_ok = 1;
break;
case COMP_MODULE:
*st = ST_END_MODULE;
target = " module";
+ eos_ok = 1;
break;
case COMP_INTERFACE:
*st = ST_END_INTERFACE;
target = " interface";
+ eos_ok = 0;
break;
case COMP_DERIVED:
*st = ST_END_TYPE;
target = " type";
+ eos_ok = 0;
break;
case COMP_IF:
*st = ST_ENDIF;
target = " if";
+ eos_ok = 0;
break;
case COMP_DO:
*st = ST_ENDDO;
target = " do";
+ eos_ok = 0;
break;
case COMP_SELECT:
*st = ST_END_SELECT;
target = " select";
+ eos_ok = 0;
break;
case COMP_FORALL:
*st = ST_END_FORALL;
target = " forall";
+ eos_ok = 0;
break;
case COMP_WHERE:
*st = ST_END_WHERE;
target = " where";
+ eos_ok = 0;
break;
default:
if (gfc_match_eos () == MATCH_YES)
{
-
- if (*st == ST_ENDIF || *st == ST_ENDDO || *st == ST_END_SELECT
- || *st == ST_END_INTERFACE || *st == ST_END_FORALL
- || *st == ST_END_WHERE)
+ if (!eos_ok)
{
-
+ /* We would have required END [something] */
gfc_error ("%s statement expected at %C",
gfc_ascii_statement (*st));
goto cleanup;
gfc_syntax_error (*st);
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_ERROR;
}
if (find_special (name, &sym))
return MATCH_ERROR;
- var_locus = *gfc_current_locus ();
+ var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */
if (current_attr.dimension
match
gfc_match_save (void)
{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *c;
gfc_symbol *sym;
match m;
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, gfc_current_locus ()) == FAILURE)
+ if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
return MATCH_ERROR;
}
- m = gfc_match (" / %s /", &sym);
+ m = gfc_match (" / %n /", &n);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;
- if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ c = gfc_get_common (n, 0);
+ c->saved = 1;
+
gfc_current_ns->seen_save = 1;
next_item:
OSDN Git Service
