mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-21 10:20:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

dump-parse-tree.c (show_common): New function.

Browse Source 
* dump-parse-tree.c (show_common): New function.
(gfc_show_namespace): Show commons.

From-SVN: r83874
This commit is contained in:
Tobias Schlüter 2004-06-29 23:18:10 +02:00 committed by Tobias Schlüter
parent 57512331da
commit fbc9b45313
5 changed files with 246 additions and 209 deletions

5
gcc/fortran/ChangeLog

@ -1,3 +1,8 @@
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>

223
gcc/fortran/decl.c

@ -874,12 +874,12 @@ done:
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;
@ -898,7 +898,10 @@ gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
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)
@ -960,7 +963,7 @@ gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
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)
@ -982,6 +985,210 @@ get_kind:
}
/* 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
@ -1242,7 +1449,7 @@ gfc_match_data_decl (void)
gfc_symbol *sym;
match m;
m = gfc_match_type_spec (&current_ts, 1);
m = match_type_spec (&current_ts, 0);
if (m != MATCH_YES)
return m;
@ -1332,7 +1539,7 @@ match_prefix (gfc_typespec * ts)
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)
{

23
gcc/fortran/dump-parse-tree.c

@ -718,6 +718,27 @@ gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
}
/* 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
@ -1432,6 +1453,8 @@ gfc_show_namespace (gfc_namespace * ns)
}
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++)

198
gcc/fortran/match.c

@ -2048,204 +2048,6 @@ cleanup:
}
/* 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. */

6
gcc/fortran/match.h

@ -75,8 +75,6 @@ match gfc_match_deallocate (void);
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);
@ -98,7 +96,6 @@ gfc_common_head *gfc_get_common (char *);
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);
@ -108,6 +105,9 @@ match gfc_match_entry (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);