* dump-parse-tree.c (show_common): New function.
(gfc_show_namespace): Show commons.
From-SVN: r83874
+2004-06-29 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
+
+ * dump-parse-tree.c (show_common): New function.
+ (gfc_show_namespace): Show commons.
+
2004-06-29 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
Andrew Vaught <andyv@firstinter.net>
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;
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)
}
+/* 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 (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 != '(')
+ {
+ 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, ts) != 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;
+ }
+
+ /* First cleanup. */
+ gfc_clear_new_implicit ();
+
+ do
+ {
+ /* 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 (&ts);
+
+ if (m != MATCH_YES && ts.type == BT_CHARACTER)
+ {
+ /* looks like we are matching CHARACTER (<len>) (<range>) */
+ m = match_char_spec (&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_current_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;
+
+ }
+ 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;
+}
+
+
/* 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
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)
{
}
+/* Function to display a common block. */
+
+static void
+show_common (gfc_symtree * st)
+{
+ gfc_symbol *s;
+
+ show_indent ();
+ gfc_status ("common: /%s/ ", st->name);
+
+ s = st->n.common->head;
+ while (s)
+ {
+ gfc_status ("%s", s->name);
+ s = s->common_next;
+ if (s)
+ gfc_status (", ");
+ }
+ gfc_status_char ('\n');
+}
+
/* Worker function to display the symbol tree. */
static void
}
gfc_current_ns = ns;
+ gfc_traverse_symtree (ns->common_root, show_common);
+
gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
}
-/* 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 (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 != '(')
- {
- 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, ts) != 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;
- }
-
- /* First cleanup. */
- gfc_clear_new_implicit ();
-
- do
- {
- /* 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_current_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;
-
- }
- 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;
-}
-
-
/* Given a name, return a pointer to the common head structure,
creating it if it does not exist.
TODO: Add to global symbol tree. */
match gfc_match_return (void);
match gfc_match_call (void);
match gfc_match_common (void);
-match gfc_match_implicit_none (void);
-match gfc_match_implicit (void);
match gfc_match_block_data (void);
match gfc_match_namelist (void);
match gfc_match_module (void);
match gfc_match_null (gfc_expr **);
match gfc_match_kind_spec (gfc_typespec *);
match gfc_match_old_kind_spec (gfc_typespec *);
-match gfc_match_type_spec (gfc_typespec *, int);
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
match gfc_match_subroutine (void);
match gfc_match_derived_decl (void);
+match gfc_match_implicit_none (void);
+match gfc_match_implicit (void);
+
/* Matchers for attribute declarations */
match gfc_match_allocatable (void);
match gfc_match_dimension (void);
projects / gcc.git / commitdiff