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

openmp.c, [...]: Next installment in the massive whitespace patch.

Browse Source 
* openmp.c, matchexp.c, module.c, scanner.c, resolve.c, st.c,
    parse.c, primary.c, options.c, misc.c, simplify.c:  Next installment
    in the massive whitespace patch.

From-SVN: r121012
This commit is contained in:
Steven G. Kargl 2007-01-20 22:01:41 +00:00
parent 70fadd09be
commit edf1eac29e
12 changed files with 1609 additions and 1700 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2007-01-20 Steven G. Kargl <kargl@gcc.gnu.org>
* openmp.c, matchexp.c, module.c, scanner.c, resolve.c, st.c,
parse.c, primary.c, options.c, misc.c, simplify.c: Next installment
in the massive whitespace patch.
2007-01-20 Roger Sayle <roger@eyesopen.com>
* module.c (mio_array_ref): The dimen_type fields of an array ref

56
gcc/fortran/matchexp.c
View File

@ -1,6 +1,6 @@
/* Expression parser.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software Foundation,
Inc.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
@ -91,7 +90,7 @@ error:
operator already. */
static match
match_defined_operator (gfc_user_op ** result)
match_defined_operator (gfc_user_op **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
@ -126,6 +125,7 @@ next_operator (gfc_intrinsic_op t)
/* Call the INTRINSIC_PARENTHESES function. This is both
used explicitly, as below, or by resolve.c to generate
temporaries. */
gfc_expr *
gfc_get_parentheses (gfc_expr *e)
{
@ -146,7 +146,7 @@ gfc_get_parentheses (gfc_expr *e)
/* Match a primary expression. */
static match
match_primary (gfc_expr ** result)
match_primary (gfc_expr **result)
{
match m;
gfc_expr *e;
@ -206,8 +206,8 @@ syntax:
/* Build an operator expression node. */
static gfc_expr *
build_node (gfc_intrinsic_op operator, locus * where,
gfc_expr * op1, gfc_expr * op2)
build_node (gfc_intrinsic_op operator, locus *where,
gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *new;
@ -226,7 +226,7 @@ build_node (gfc_intrinsic_op operator, locus * where,
/* Match a level 1 expression. */
static match
match_level_1 (gfc_expr ** result)
match_level_1 (gfc_expr **result)
{
gfc_user_op *uop;
gfc_expr *e, *f;
@ -272,14 +272,12 @@ match_level_1 (gfc_expr ** result)
or add-operand
*/
static match match_ext_mult_operand (gfc_expr ** result);
static match match_ext_add_operand (gfc_expr ** result);
static match match_ext_mult_operand (gfc_expr **result);
static match match_ext_add_operand (gfc_expr **result);
static int
match_add_op (void)
{
if (next_operator (INTRINSIC_MINUS))
return -1;
if (next_operator (INTRINSIC_PLUS))
@ -289,7 +287,7 @@ match_add_op (void)
static match
match_mult_operand (gfc_expr ** result)
match_mult_operand (gfc_expr **result)
{
gfc_expr *e, *exp, *r;
locus where;
@ -332,7 +330,7 @@ match_mult_operand (gfc_expr ** result)
static match
match_ext_mult_operand (gfc_expr ** result)
match_ext_mult_operand (gfc_expr **result)
{
gfc_expr *all, *e;
locus where;
@ -345,8 +343,8 @@ match_ext_mult_operand (gfc_expr ** result)
if (i == 0)
return match_mult_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
" arithmetic operator (use parentheses) at %C")
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
"arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
@ -372,7 +370,7 @@ match_ext_mult_operand (gfc_expr ** result)
static match
match_add_operand (gfc_expr ** result)
match_add_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where, old_loc;
@ -436,7 +434,7 @@ match_add_operand (gfc_expr ** result)
static match
match_ext_add_operand (gfc_expr ** result)
match_ext_add_operand (gfc_expr **result)
{
gfc_expr *all, *e;
locus where;
@ -449,8 +447,8 @@ match_ext_add_operand (gfc_expr ** result)
if (i == 0)
return match_add_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
" arithmetic operator (use parentheses) at %C")
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
"arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
@ -478,7 +476,7 @@ match_ext_add_operand (gfc_expr ** result)
/* Match a level 2 expression. */
static match
match_level_2 (gfc_expr ** result)
match_level_2 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
@ -521,7 +519,7 @@ match_level_2 (gfc_expr ** result)
all->where = where;
/* Append add-operands to the sum */
/* Append add-operands to the sum. */
for (;;)
{
@ -563,7 +561,7 @@ match_level_2 (gfc_expr ** result)
/* Match a level three expression. */
static match
match_level_3 (gfc_expr ** result)
match_level_3 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
@ -609,7 +607,7 @@ match_level_3 (gfc_expr ** result)
/* Match a level 4 expression. */
static match
match_level_4 (gfc_expr ** result)
match_level_4 (gfc_expr **result)
{
gfc_expr *left, *right, *r;
gfc_intrinsic_op i;
@ -693,7 +691,7 @@ match_level_4 (gfc_expr ** result)
static match
match_and_operand (gfc_expr ** result)
match_and_operand (gfc_expr **result)
{
gfc_expr *e, *r;
locus where;
@ -726,7 +724,7 @@ match_and_operand (gfc_expr ** result)
static match
match_or_operand (gfc_expr ** result)
match_or_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
@ -769,7 +767,7 @@ match_or_operand (gfc_expr ** result)
static match
match_equiv_operand (gfc_expr ** result)
match_equiv_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
@ -814,7 +812,7 @@ match_equiv_operand (gfc_expr ** result)
/* Match a level 5 expression. */
static match
match_level_5 (gfc_expr ** result)
match_level_5 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
@ -873,7 +871,7 @@ match_level_5 (gfc_expr ** result)
level 5 expressions separated by binary operators. */
match
gfc_match_expr (gfc_expr ** result)
gfc_match_expr (gfc_expr **result)
{
gfc_expr *all, *e;
gfc_user_op *uop;

31
gcc/fortran/misc.c
View File

@ -1,6 +1,6 @@
/* Miscellaneous stuff that doesn't fit anywhere else.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
@ -20,12 +20,10 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
/* Get a block of memory. Many callers assume that the memory we
return is zeroed. */
@ -54,7 +52,6 @@ gfc_getmem (size_t n)
void
gfc_free (void *p)
{
if (p != NULL)
free (p);
}
@ -63,10 +60,10 @@ gfc_free (void *p)
#undef temp
/* Get terminal width */
/* Get terminal width. */
int
gfc_terminal_width(void)
gfc_terminal_width (void)
{
return 80;
}
@ -75,9 +72,8 @@ gfc_terminal_width(void)
/* Initialize a typespec to unknown. */
void
gfc_clear_ts (gfc_typespec * ts)
gfc_clear_ts (gfc_typespec *ts)
{
ts->type = BT_UNKNOWN;
ts->kind = 0;
ts->derived = NULL;
@ -154,9 +150,9 @@ gfc_basic_typename (bt type)
the argument list of a single statement. */
const char *
gfc_typename (gfc_typespec * ts)
gfc_typename (gfc_typespec *ts)
{
static char buffer1[60], buffer2[60];
static char buffer1[60], buffer2[60]; /* FIXME: Buffer overflow. */
static int flag = 0;
char *buffer;
@ -204,9 +200,8 @@ gfc_typename (gfc_typespec * ts)
returning a pointer to the string. */
const char *
gfc_code2string (const mstring * m, int code)
gfc_code2string (const mstring *m, int code)
{
while (m->string != NULL)
{
if (m->tag == code)
@ -220,13 +215,11 @@ gfc_code2string (const mstring * m, int code)
/* Given an mstring array and a string, returns the value of the tag
field. Returns the final tag if no matches to the string are
found. */
field. Returns the final tag if no matches to the string are found. */
int
gfc_string2code (const mstring * m, const char *string)
gfc_string2code (const mstring *m, const char *string)
{
for (; m->string != NULL; m++)
if (strcmp (m->string, string) == 0)
return m->tag;
@ -237,10 +230,10 @@ gfc_string2code (const mstring * m, const char *string)
/* Convert an intent code to a string. */
/* TODO: move to gfortran.h as define. */
const char *
gfc_intent_string (sym_intent i)
{
return gfc_code2string (intents, i);
}
@ -265,7 +258,6 @@ gfc_init_1 (void)
void
gfc_init_2 (void)
{
gfc_symbol_init_2 ();
gfc_module_init_2 ();
}
@ -289,7 +281,6 @@ gfc_done_1 (void)
void
gfc_done_2 (void)
{
gfc_symbol_done_2 ();
gfc_module_done_2 ();
}

479
gcc/fortran/module.c
View File

File diff suppressed because it is too large Load Diff

126
gcc/fortran/openmp.c
View File

@ -1,5 +1,6 @@
/* OpenMP directive matching and resolving.
Copyright (C) 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Jakub Jelinek
This file is part of GCC.
@ -19,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
@ -410,6 +410,7 @@ gfc_match_omp_parallel (void)
return MATCH_YES;
}
match
gfc_match_omp_critical (void)
{
@ -424,6 +425,7 @@ gfc_match_omp_critical (void)
return MATCH_YES;
}
match
gfc_match_omp_do (void)
{
@ -435,6 +437,7 @@ gfc_match_omp_do (void)
return MATCH_YES;
}
match
gfc_match_omp_flush (void)
{
@ -450,6 +453,7 @@ gfc_match_omp_flush (void)
return MATCH_YES;
}
match
gfc_match_omp_threadprivate (void)
{
@ -478,8 +482,8 @@ gfc_match_omp_threadprivate (void)
{
case MATCH_YES:
if (sym->attr.in_common)
gfc_error_now ("Threadprivate variable at %C is an element of"
" a COMMON block");
gfc_error_now ("Threadprivate variable at %C is an element of "
"a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
@ -525,6 +529,7 @@ cleanup:
return MATCH_ERROR;
}
match
gfc_match_omp_parallel_do (void)
{
@ -537,6 +542,7 @@ gfc_match_omp_parallel_do (void)
return MATCH_YES;
}
match
gfc_match_omp_parallel_sections (void)
{
@ -549,6 +555,7 @@ gfc_match_omp_parallel_sections (void)
return MATCH_YES;
}
match
gfc_match_omp_parallel_workshare (void)
{
@ -560,6 +567,7 @@ gfc_match_omp_parallel_workshare (void)
return MATCH_YES;
}
match
gfc_match_omp_sections (void)
{
@ -571,6 +579,7 @@ gfc_match_omp_sections (void)
return MATCH_YES;
}
match
gfc_match_omp_single (void)
{
@ -583,6 +592,7 @@ gfc_match_omp_single (void)
return MATCH_YES;
}
match
gfc_match_omp_workshare (void)
{
@ -593,6 +603,7 @@ gfc_match_omp_workshare (void)
return MATCH_YES;
}
match
gfc_match_omp_master (void)
{
@ -603,6 +614,7 @@ gfc_match_omp_master (void)
return MATCH_YES;
}
match
gfc_match_omp_ordered (void)
{
@ -613,6 +625,7 @@ gfc_match_omp_ordered (void)
return MATCH_YES;
}
match
gfc_match_omp_atomic (void)
{
@ -623,6 +636,7 @@ gfc_match_omp_atomic (void)
return MATCH_YES;
}
match
gfc_match_omp_barrier (void)
{
@ -633,6 +647,7 @@ gfc_match_omp_barrier (void)
return MATCH_YES;
}
match
gfc_match_omp_end_nowait (void)
{
@ -646,6 +661,7 @@ gfc_match_omp_end_nowait (void)
return MATCH_YES;
}
match
gfc_match_omp_end_single (void)
{
@ -663,6 +679,7 @@ gfc_match_omp_end_single (void)
return MATCH_YES;
}
/* OpenMP directive resolving routines. */
static void
@ -691,16 +708,16 @@ resolve_omp_clauses (gfc_code *code)
gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("NUM_THREADS clause at %L requires a scalar"
" INTEGER expression", &expr->where);
gfc_error ("NUM_THREADS clause at %L requires a scalar "
"INTEGER expression", &expr->where);
}
if (omp_clauses->chunk_size)
{
gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("SCHEDULE clause's chunk_size at %L requires"
" a scalar INTEGER expression", &expr->where);
gfc_error ("SCHEDULE clause's chunk_size at %L requires "
"a scalar INTEGER expression", &expr->where);
}
/* Check that no symbol appears on multiple clauses, except that
@ -774,19 +791,19 @@ resolve_omp_clauses (gfc_code *code)
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause"
" at %L", n->sym->name, &code->loc);
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, &code->loc);
if (n->sym->attr.allocatable)
gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE"
" at %L", n->sym->name, &code->loc);
gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
"at %L", n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at"
" %L", n->sym->name, &code->loc);
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
"%L", n->sym->name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, &code->loc);
@ -819,8 +836,8 @@ resolve_omp_clauses (gfc_code *code)
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable '%s' in %s clause is used in"
" NAMELIST statement at %L",
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, &code->loc);
switch (list)
{
@ -839,8 +856,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_EQV:
case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL"
" at %L",
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
"at %L",
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
@ -850,8 +867,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
gfc_error ("%s REDUCTION variable '%s' must be"
" INTEGER or REAL at %L",
gfc_error ("%s REDUCTION variable '%s' must be "
"INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, &code->loc);
break;
@ -859,8 +876,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_IOR:
case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER)
gfc_error ("%s REDUCTION variable '%s' must be INTEGER"
" at %L",
gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
"at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, &code->loc);
@ -878,6 +895,7 @@ resolve_omp_clauses (gfc_code *code)
}
}
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
static bool
@ -917,6 +935,7 @@ expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
}
}
/* If EXPR is a conversion function that widens the type
if WIDENING is true or narrows the type if WIDENING is false,
return the inner expression, otherwise return NULL. */
@ -950,6 +969,7 @@ is_conversion (gfc_expr *expr, bool widening)
return NULL;
}
static void
resolve_omp_atomic (gfc_code *code)
{
@ -968,8 +988,8 @@ resolve_omp_atomic (gfc_code *code)
&& code->expr->ts.type != BT_COMPLEX
&& code->expr->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
" intrinsic type at %L", &code->loc);
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
"intrinsic type at %L", &code->loc);
return;
}
@ -1008,8 +1028,8 @@ resolve_omp_atomic (gfc_code *code)
alt_op = INTRINSIC_EQV;
break;
default:
gfc_error ("!$OMP ATOMIC assignment operator must be"
" +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
gfc_error ("!$OMP ATOMIC assignment operator must be "
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where);
return;
}
@ -1056,8 +1076,8 @@ resolve_omp_atomic (gfc_code *code)
if (v == NULL)
{
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
" or var = expr op var at %L", &expr2->where);
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
"or var = expr op var at %L", &expr2->where);
return;
}
@ -1070,9 +1090,9 @@ resolve_omp_atomic (gfc_code *code)
case INTRINSIC_DIVIDE:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not"
" mathematically equivalent to var = var op"
" (expr) at %L", &expr2->where);
gfc_error ("!$OMP ATOMIC var = var op expr not "
"mathematically equivalent to var = var op "
"(expr) at %L", &expr2->where);
break;
default:
break;
@ -1102,8 +1122,8 @@ resolve_omp_atomic (gfc_code *code)
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
{
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
" must be scalar and cannot reference var at %L",
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
"must be scalar and cannot reference var at %L",
&expr2->where);
return;
}
@ -1126,15 +1146,15 @@ resolve_omp_atomic (gfc_code *code)
case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL)
{
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
"or IEOR must have two arguments at %L",
&expr2->where);
return;
}
break;
default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
" MIN, MAX, IAND, IOR or IEOR at %L",
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
"MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where);
return;
}
@ -1149,17 +1169,17 @@ resolve_omp_atomic (gfc_code *code)
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
" reference '%s' at %L", var->name, &arg->expr->where);
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
"reference '%s' at %L", var->name, &arg->expr->where);
if (arg->expr->rank != 0)
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
" at %L", &arg->expr->where);
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
"at %L", &arg->expr->where);
}
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
" be '%s' at %L", var->name, &expr2->where);
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
"be '%s' at %L", var->name, &expr2->where);
return;
}
@ -1176,10 +1196,11 @@ resolve_omp_atomic (gfc_code *code)
}
}
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
" on right hand side at %L", &expr2->where);
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
"on right hand side at %L", &expr2->where);
}
struct omp_context
{
gfc_code *code;
@ -1189,6 +1210,7 @@ struct omp_context
} *omp_current_ctx;
gfc_code *omp_current_do_code;
void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
{
@ -1197,6 +1219,7 @@ gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
gfc_resolve_blocks (code->block, ns);
}
void
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
{
@ -1225,6 +1248,7 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
pointer_set_destroy (ctx.private_iterators);
}
/* Note a DO iterator variable. This is special in !$omp parallel
construct, where they are predetermined private. */
@ -1260,6 +1284,7 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
}
}
static void
resolve_omp_do (gfc_code *code)
{
@ -1273,8 +1298,8 @@ resolve_omp_do (gfc_code *code)
do_code = code->block->next;
if (do_code->op == EXEC_DO_WHILE)
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
&do_code->loc);
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
"at %L", &do_code->loc);
else
{
gcc_assert (do_code->op == EXEC_DO);
@ -1283,22 +1308,23 @@ resolve_omp_do (gfc_code *code)
&do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
&do_code->loc);
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
"at %L", &do_code->loc);
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym)
{
gfc_error ("!$OMP DO iteration variable present on clause"
" other than PRIVATE or LASTPRIVATE at %L",
gfc_error ("!$OMP DO iteration variable present on clause "
"other than PRIVATE or LASTPRIVATE at %L",
&do_code->loc);
break;
}
}
}
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */

27
gcc/fortran/options.c
View File

@ -1,5 +1,5 @@
/* Parse and display command line options.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
@ -31,7 +30,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "options.h"
#include "params.h"
#include "tree-inline.h"
#include "gfortran.h"
#include "target.h"
@ -94,8 +92,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.fpe = 0;
/* Argument pointers cannot point to anything
but their argument. */
/* Argument pointers cannot point to anything but their argument. */
flag_argument_noalias = 3;
flag_errno_math = 0;
@ -112,7 +109,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.fshort_enums = targetm.default_short_enums ();
/* Increase MAX_ALIASED_VOPS to account for different characteristics
of fortran regarding VOPs. */
of Fortran regarding VOPs. */
MAX_ALIASED_VOPS = 50;
return CL_Fortran;
@ -125,7 +122,6 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
static gfc_source_form
form_from_filename (const char *filename)
{
static const struct
{
const char *extension;
@ -223,6 +219,7 @@ gfc_post_options (const char **pfilename)
i = strlen (canon_source_file);
while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i]))
i--;
if (i != 0)
{
source_path = alloca (i + 1);
@ -260,8 +257,7 @@ gfc_post_options (const char **pfilename)
gfc_warning_now ("'-fd-lines-as-comments' has no effect "
"in free form");
else if (gfc_option.flag_d_lines == 1)
gfc_warning_now ("'-fd-lines-as-code' has no effect "
"in free form");
gfc_warning_now ("'-fd-lines-as-code' has no effect in free form");
}
flag_inline_trees = 1;
@ -304,7 +300,6 @@ gfc_post_options (const char **pfilename)
static void
set_Wall (void)
{
gfc_option.warn_aliasing = 1;
gfc_option.warn_ampersand = 1;
gfc_option.warn_line_truncation = 1;
@ -350,12 +345,13 @@ gfc_handle_module_path_options (const char *arg)
gfc_add_include_path (gfc_option.module_dir, true);
}
static void
gfc_handle_fpe_trap_option (const char *arg)
{
int result, pos = 0, n;
static const char * const exception[] = { "invalid", "denormal", "zero",
"overflow", "underflow",
"overflow", "underflow",
"precision", NULL };
static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL,
GFC_FPE_ZERO, GFC_FPE_OVERFLOW,
@ -366,8 +362,10 @@ gfc_handle_fpe_trap_option (const char *arg)
{
while (*arg == ',')
arg++;
while (arg[pos] && arg[pos] != ',')
pos++;
result = 0;
for (n = 0; exception[n] != NULL; n++)
{
@ -380,13 +378,15 @@ gfc_handle_fpe_trap_option (const char *arg)
break;
}
}
if (! result)
if (!result)
gfc_fatal_error ("Argument to -ffpe-trap is not valid: %s", arg);
}
}
/* Handle command-line options. Returns 0 if unrecognized, 1 if
recognized and handled. */
int
gfc_handle_option (size_t scode, const char *arg, int value)
{
@ -665,7 +665,8 @@ gfc_handle_option (size_t scode, const char *arg, int value)
case OPT_fmax_subrecord_length_:
if (value > MAX_SUBRECORD_LENGTH)
gfc_fatal_error ("Maximum subrecord length cannot exceed %d", MAX_SUBRECORD_LENGTH);
gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
MAX_SUBRECORD_LENGTH);
gfc_option.max_subrecord_length = value;
}

305
gcc/fortran/parse.c
View File

@ -1,6 +1,6 @@
/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include <setjmp.h>
@ -28,9 +27,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "match.h"
#include "parse.h"
/* Current statement label. Zero means no statement label. Because
new_st can get wiped during statement matching, we have to keep it
separate. */
/* Current statement label. Zero means no statement label. Because new_st
can get wiped during statement matching, we have to keep it separate. */
gfc_st_label *gfc_statement_label;
@ -51,7 +49,7 @@ static void reject_statement (void);
gfc_match_eos(). */
static match
match_word (const char *str, match (*subr) (void), locus * old_locus)
match_word (const char *str, match (*subr) (void), locus *old_locus)
{
match m;
@ -79,11 +77,11 @@ match_word (const char *str, match (*subr) (void), locus * old_locus)
ambiguity. */
#define match(keyword, subr, st) \
do { \
do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
return st; \
return st; \
else \
undo_new_statement (); \
undo_new_statement (); \
} while (0);
static gfc_statement
@ -322,7 +320,8 @@ decode_omp_directive (void)
if (gfc_pure (NULL))
{
gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
gfc_error_now ("OpenMP directives at %C may not appear in PURE "
"or ELEMENTAL procedures");
gfc_error_recovery ();
return ST_NONE;
}
@ -434,7 +433,7 @@ next_free (void)
{
gfc_match_small_literal_int (&c, &cnt);
if (cnt > 5)
if (cnt > 5)
gfc_error_now ("Too many digits in statement label at %C");
if (c == 0)
@ -457,16 +456,16 @@ next_free (void)
if (at_bol && gfc_peek_char () == ';')
{
gfc_error_now
("Semicolon at %C needs to be preceded by statement");
gfc_error_now ("Semicolon at %C needs to be preceded by "
"statement");
gfc_next_char (); /* Eat up the semicolon. */
return ST_NONE;
}
if (gfc_match_eos () == MATCH_YES)
{
gfc_warning_now
("Ignoring statement label in empty statement at %C");
gfc_warning_now ("Ignoring statement label in empty statement "
"at %C");
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
@ -669,8 +668,7 @@ next_statement (void)
break;
}
st =
(gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE)
break;
@ -723,21 +721,19 @@ next_statement (void)
are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
case ST_END_PROGRAM: case ST_END_SUBROUTINE
case ST_END_PROGRAM: case ST_END_SUBROUTINE
/* Push a new state onto the stack. */
static void
push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
{
p->state = new_state;
p->previous = gfc_state_stack;
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
gfc_state_stack = p;
}
@ -747,7 +743,6 @@ push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
static void
pop_state (void)
{
gfc_state_stack = gfc_state_stack->previous;
}
@ -770,7 +765,7 @@ gfc_find_state (gfc_compile_state state)
/* Starts a new level in the statement list. */
static gfc_code *
new_level (gfc_code * q)
new_level (gfc_code *q)
{
gfc_code *p;
@ -857,8 +852,8 @@ check_statement_label (gfc_statement st)
break;
/* Statement labels are not restricted from appearing on a
particular line. However, there are plenty of situations
where the resulting label can't be referenced. */
particular line. However, there are plenty of situations
where the resulting label can't be referenced. */
default:
type = ST_LABEL_BAD_TARGET;
@ -1230,7 +1225,7 @@ gfc_ascii_statement (gfc_statement st)
/* Create a symbol for the main program and assign it to ns->proc_name. */
static void
main_program_symbol (gfc_namespace * ns)
main_program_symbol (gfc_namespace *ns)
{
gfc_symbol *main_program;
symbol_attribute attr;
@ -1254,7 +1249,6 @@ main_program_symbol (gfc_namespace * ns)
static void
accept_statement (gfc_statement st)
{
switch (st)
{
case ST_USE:
@ -1275,8 +1269,8 @@ accept_statement (gfc_statement st)
break;
/* If the statement is the end of a block, lay down a special code
that allows a branch to the end of the block from within the
construct. */
that allows a branch to the end of the block from within the
construct. */
case ST_ENDIF:
case ST_END_SELECT:
@ -1289,8 +1283,8 @@ accept_statement (gfc_statement st)
break;
/* The end-of-program unit statements do not get the special
marker and require a statement of some sort if they are a
branch target. */
marker and require a statement of some sort if they are a
branch target. */
case ST_END_PROGRAM:
case ST_END_FUNCTION:
@ -1338,7 +1332,6 @@ reject_statement (void)
static void
unexpected_statement (gfc_statement st)
{
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
reject_statement ();
@ -1354,30 +1347,30 @@ unexpected_statement (gfc_statement st)
valid before calling here, ie ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
+---------------------------------------+
| program subroutine function module |
+---------------------------------------+
| use |
+---------------------------------------+
| import |
+---------------------------------------+
| | implicit none |
| +-----------+------------------+
| | parameter | implicit |
| +-----------+------------------+
| format | | derived type |
| entry | parameter | interface |
| | data | specification |
| | | statement func |
| +-----------+------------------+
| | data | executable |
+--------+-----------+------------------+
| contains |
+---------------------------------------+
| internal module/subprogram |
+---------------------------------------+
| end |
+---------------------------------------+
+---------------------------------------+
| program subroutine function module |
+---------------------------------------+
| use |
+---------------------------------------+
| import |
+---------------------------------------+
| | implicit none |
| +-----------+------------------+
| | parameter | implicit |
| +-----------+------------------+
| format | | derived type |
| entry | parameter | interface |
| | data | specification |
| | | statement func |
| +-----------+------------------+
| | data | executable |
+--------+-----------+------------------+
| contains |
+---------------------------------------+
| internal module/subprogram |
+---------------------------------------+
| end |
+---------------------------------------+
*/
@ -1394,7 +1387,7 @@ typedef struct
st_state;
static try
verify_st_order (st_state * p, gfc_statement st)
verify_st_order (st_state *p, gfc_statement st)
{
switch (st)
@ -1419,10 +1412,10 @@ verify_st_order (st_state * p, gfc_statement st)
if (p->state > ORDER_IMPLICIT_NONE)
goto order;
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
statement disqualifies a USE but not an IMPLICIT NONE.
Duplicate IMPLICIT NONEs are caught when the implicit types
are set. */
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
statement disqualifies a USE but not an IMPLICIT NONE.
Duplicate IMPLICIT NONEs are caught when the implicit types
are set. */
p->state = ORDER_IMPLICIT_NONE;
break;
@ -1468,9 +1461,8 @@ verify_st_order (st_state * p, gfc_statement st)
break;
default:
gfc_internal_error
("Unexpected %s statement in verify_st_order() at %C",
gfc_ascii_statement (st));
gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
gfc_ascii_statement (st));
}
/* All is well, record the statement in case we need it next time. */
@ -1560,8 +1552,8 @@ parse_derived (void)
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error
("PRIVATE statement in TYPE at %C must be inside a MODULE");
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
error_flag = 1;
break;
}
@ -1619,8 +1611,8 @@ parse_derived (void)
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
if (c->allocatable || (c->ts.type == BT_DERIVED
&& c->ts.derived->attr.alloc_comp))
if (c->allocatable
|| (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
{
sym->attr.alloc_comp = 1;
break;
@ -1631,7 +1623,6 @@ parse_derived (void)
}
/* Parse an ENUM. */
static void
@ -1653,35 +1644,36 @@ parse_enum (void)
{
st = next_statement ();
switch (st)
{
case ST_NONE:
unexpected_eof ();
break;
{
case ST_NONE:
unexpected_eof ();
break;
case ST_ENUMERATOR:
case ST_ENUMERATOR:
seen_enumerator = 1;
accept_statement (st);
break;
accept_statement (st);
break;
case ST_END_ENUM:
compiling_enum = 0;
case ST_END_ENUM:
compiling_enum = 0;
if (!seen_enumerator)
{
gfc_error ("ENUM declaration at %C has no ENUMERATORS");
{
gfc_error ("ENUM declaration at %C has no ENUMERATORS");
error_flag = 1;
}
accept_statement (st);
break;
}
accept_statement (st);
break;
default:
gfc_free_enum_history ();
unexpected_statement (st);
break;
}
default:
gfc_free_enum_history ();
unexpected_statement (st);
break;
}
}
pop_state ();
}
/* Parse an interface. We must be able to deal with the possibility
of recursive interfaces. The parse_spec() subroutine is mutually
recursive with parse_interface(). */
@ -1704,7 +1696,8 @@ parse_interface (void)
save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC
|| current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
|| current_interface.type == INTERFACE_USER_OP)
? gfc_new_block : NULL;
push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE;
@ -1768,14 +1761,12 @@ loop:
if (new_state != current_state)
{
if (new_state == COMP_SUBROUTINE)
gfc_error
("SUBROUTINE at %C does not belong in a generic function "
"interface");
gfc_error ("SUBROUTINE at %C does not belong in a "
"generic function interface");
if (new_state == COMP_FUNCTION)
gfc_error
("FUNCTION at %C does not belong in a generic subroutine "
"interface");
gfc_error ("FUNCTION at %C does not belong in a "
"generic subroutine interface");
}
}
}
@ -1945,7 +1936,7 @@ parse_where_block (void)
case ST_WHERE_BLOCK:
parse_where_block ();
break;
break;
case ST_ASSIGNMENT:
case ST_WHERE:
@ -1955,9 +1946,8 @@ parse_where_block (void)
case ST_ELSEWHERE:
if (seen_empty_else)
{
gfc_error
("ELSEWHERE statement at %C follows previous unmasked "
"ELSEWHERE");
gfc_error ("ELSEWHERE statement at %C follows previous "
"unmasked ELSEWHERE");
break;
}
@ -1982,7 +1972,6 @@ parse_where_block (void)
reject_statement ();
break;
}
}
while (st != ST_END_WHERE);
@ -2088,9 +2077,8 @@ parse_if_block (void)
case ST_ELSEIF:
if (seen_else)
{
gfc_error
("ELSE IF statement at %C cannot follow ELSE statement at %L",
&else_locus);
gfc_error ("ELSE IF statement at %C cannot follow ELSE "
"statement at %L", &else_locus);
reject_statement ();
break;
@ -2168,9 +2156,8 @@ parse_select_block (void)
if (st == ST_CASE)
break;
gfc_error
("Expected a CASE or END SELECT statement following SELECT CASE "
"at %C");
gfc_error ("Expected a CASE or END SELECT statement following SELECT "
"CASE at %C");
reject_statement ();
}
@ -2200,8 +2187,8 @@ parse_select_block (void)
case ST_END_SELECT:
break;
/* Can't have an executable statement because of
parse_executable(). */
/* Can't have an executable statement because of
parse_executable(). */
default:
unexpected_statement (st);
break;
@ -2261,8 +2248,7 @@ check_do_closure (void)
if (p == gfc_state_stack)
return 1;
gfc_error
("End of nonblock DO statement at %C is within another block");
gfc_error ("End of nonblock DO statement at %C is within another block");
return 2;
}
@ -2320,8 +2306,8 @@ loop:
case ST_ENDDO:
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
gfc_error_now
("Statement label in ENDDO at %C doesn't match DO label");
gfc_error_now ("Statement label in ENDDO at %C doesn't match "
"DO label");
if (gfc_statement_label != NULL)
{
@ -2336,9 +2322,8 @@ loop:
name, but in that case we must have seen ST_ENDDO first).
We only complain about this in pedantic mode. */
if (gfc_current_block () != NULL)
gfc_error_now
("named block DO at %L requires matching ENDDO name",
&gfc_current_block()->declared_at);
gfc_error_now ("named block DO at %L requires matching ENDDO name",
&gfc_current_block()->declared_at);
break;
@ -2387,12 +2372,12 @@ parse_omp_do (gfc_statement omp_st)
&& gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
{
/* In
DO 100 I=1,10
!$OMP DO
DO J=1,10
...
100 CONTINUE
there should be no !$OMP END DO. */
DO 100 I=1,10
!$OMP DO
DO J=1,10
...
100 CONTINUE
there should be no !$OMP END DO. */
pop_state ();
return ST_IMPLIED_ENDDO;
}
@ -2593,8 +2578,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
|| (new_st.ext.omp_name != NULL
&& strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
gfc_error ("Name after !$omp critical and !$omp end critical does"
" not match at %C");
gfc_error ("Name after !$omp critical and !$omp end critical does "
"not match at %C");
gfc_free ((char *) new_st.ext.omp_name);
break;
case EXEC_OMP_END_SINGLE:
@ -2649,9 +2634,8 @@ parse_executable (gfc_statement st)
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
gfc_error
("%s statement at %C cannot terminate a non-block DO loop",
gfc_ascii_statement (st));
gfc_error ("%s statement at %C cannot terminate a non-block "
"DO loop", gfc_ascii_statement (st));
break;
default:
@ -2738,7 +2722,7 @@ static void parse_progunit (gfc_statement);
the child namespace as the parser didn't know about this procedure. */
static void
gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
{
gfc_namespace *ns;
gfc_symtree *st;
@ -2756,17 +2740,17 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
if ((old_sym->attr.flavor == FL_PROCEDURE
|| old_sym->ts.type == BT_UNKNOWN)
&& old_sym->ns == ns
&& ! old_sym->attr.contained)
{
/* Replace it with the symbol from the parent namespace. */
st->n.sym = sym;
sym->refs++;
&& !old_sym->attr.contained)
{
/* Replace it with the symbol from the parent namespace. */
st->n.sym = sym;
sym->refs++;
/* Free the old (local) symbol. */
old_sym->refs--;
if (old_sym->refs == 0)
gfc_free_symbol (old_sym);
}
/* Free the old (local) symbol. */
old_sym->refs--;
if (old_sym->refs == 0)
gfc_free_symbol (old_sym);
}
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
@ -2815,9 +2799,8 @@ parse_contained (int module)
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
gfc_error
("Contained procedure '%s' at %C is already ambiguous",
gfc_new_block->name);
gfc_error ("Contained procedure '%s' at %C is already "
"ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
@ -2835,18 +2818,18 @@ parse_contained (int module)
gfc_commit_symbols ();
}
else
sym = gfc_new_block;
else
sym = gfc_new_block;
/* Mark this as a contained function, so it isn't replaced
by other module functions. */
sym->attr.contained = 1;
/* Mark this as a contained function, so it isn't replaced
by other module functions. */
sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */
gfc_fixup_sibling_symbols (sym, gfc_current_ns);
/* Fix up any sibling functions that refer to this one. */
gfc_fixup_sibling_symbols (sym, gfc_current_ns);
/* Or refer to any of its alternate entry points. */
for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
@ -2857,8 +2840,7 @@ parse_contained (int module)
pop_state ();
break;
/* These statements are associated with the end of the host
unit. */
/* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_PROGRAM:
@ -2888,9 +2870,8 @@ parse_contained (int module)
pop_state ();
if (!contains_statements)
/* This is valid in Fortran 2008. */
gfc_notify_std (GFC_STD_GNU, "Extension: "
"CONTAINS statement without FUNCTION "
"or SUBROUTINE statement at %C");
gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
"FUNCTION or SUBROUTINE statement at %C");
}
@ -3028,22 +3009,23 @@ parse_block_data (void)
{
if (blank_block)
gfc_error ("Blank BLOCK DATA at %C conflicts with "
"prior BLOCK DATA at %L", &blank_locus);
"prior BLOCK DATA at %L", &blank_locus);
else
{
blank_block = 1;
blank_locus = gfc_current_locus;
blank_block = 1;
blank_locus = gfc_current_locus;
}
}
else
{
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
global_used(s, NULL);
else
{
s->type = GSYM_BLOCK_DATA;
s->where = gfc_current_locus;
s->type = GSYM_BLOCK_DATA;
s->where = gfc_current_locus;
s->defined = 1;
}
}
@ -3115,7 +3097,8 @@ add_global_procedure (int sub)
s = gfc_get_gsymbol(gfc_new_block->name);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
@ -3237,7 +3220,7 @@ loop:
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
main_program_symbol(gfc_current_ns);
main_program_symbol (gfc_current_ns);
parse_progunit (st);
break;
}

166
gcc/fortran/primary.c
View File

@ -1,5 +1,5 @@
/* Primary expression subroutines
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
@ -179,7 +178,7 @@ match_digits (int signflag, int radix, char *buffer)
A sign will be accepted if signflag is set. */
static match
match_integer_constant (gfc_expr ** result, int signflag)
match_integer_constant (gfc_expr **result, int signflag)
{
int length, kind;
locus old_loc;
@ -231,12 +230,12 @@ match_integer_constant (gfc_expr ** result, int signflag)
/* Match a Hollerith constant. */
static match
match_hollerith_constant (gfc_expr ** result)
match_hollerith_constant (gfc_expr **result)
{
locus old_loc;
gfc_expr * e = NULL;
const char * msg;
char * buffer;
gfc_expr *e = NULL;
const char *msg;
char *buffer;
int num;
int i;
@ -244,11 +243,10 @@ match_hollerith_constant (gfc_expr ** result)
gfc_gobble_whitespace ();
if (match_integer_constant (&e, 0) == MATCH_YES
&& gfc_match_char ('h') == MATCH_YES)
&& gfc_match_char ('h') == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Extension: Hollerith constant at %C")
== FAILURE)
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
"at %C") == FAILURE)
goto cleanup;
msg = gfc_extract_int (e, &num);
@ -259,14 +257,14 @@ match_hollerith_constant (gfc_expr ** result)
}
if (num == 0)
{
gfc_error ("Invalid Hollerith constant: %L must contain at least one "
"character", &old_loc);
gfc_error ("Invalid Hollerith constant: %L must contain at least "
"one character", &old_loc);
goto cleanup;
}
if (e->ts.kind != gfc_default_integer_kind)
{
gfc_error ("Invalid Hollerith constant: Integer kind at %L "
"should be default", &old_loc);
"should be default", &old_loc);
goto cleanup;
}
else
@ -277,9 +275,9 @@ match_hollerith_constant (gfc_expr ** result)
buffer[i] = gfc_next_char_literal (1);
}
gfc_free_expr (e);
e = gfc_constant_result (BT_HOLLERITH,
gfc_default_character_kind, &gfc_current_locus);
e->value.character.string = gfc_getmem (num+1);
e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
&gfc_current_locus);
e->value.character.string = gfc_getmem (num + 1);
memcpy (e->value.character.string, buffer, num);
e->value.character.string[num] = '\0';
e->value.character.length = num;
@ -305,7 +303,7 @@ cleanup:
and 'a1...'z. An additional extension is the use of x for z. */
static match
match_boz_constant (gfc_expr ** result)
match_boz_constant (gfc_expr **result)
{
int post, radix, delim, length, x_hex, kind;
locus old_loc, start_loc;
@ -435,7 +433,7 @@ backup:
is nonzero. Allow integer constants if allow_int is true. */
static match
match_real_constant (gfc_expr ** result, int signflag)
match_real_constant (gfc_expr **result, int signflag)
{
int kind, c, count, seen_dp, seen_digits, exp_char;
locus old_loc, temp_loc;
@ -472,7 +470,8 @@ match_real_constant (gfc_expr ** result, int signflag)
if (seen_dp)
goto done;
/* Check to see if "." goes with a following operator like ".eq.". */
/* Check to see if "." goes with a following operator like
".eq.". */
temp_loc = gfc_current_locus;
c = gfc_next_char ();
@ -500,8 +499,7 @@ match_real_constant (gfc_expr ** result, int signflag)
break;
}
if (!seen_digits
|| (c != 'e' && c != 'd' && c != 'q'))
if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
@ -573,8 +571,8 @@ done:
case 'd':
if (kind != -2)
{
gfc_error
("Real number at %C has a 'd' exponent and an explicit kind");
gfc_error ("Real number at %C has a 'd' exponent and an explicit "
"kind");
goto cleanup;
}
kind = gfc_default_double_kind;
@ -605,7 +603,7 @@ done:
case ARITH_UNDERFLOW:
if (gfc_option.warn_underflow)
gfc_warning ("Real constant underflows its kind at %C");
gfc_warning ("Real constant underflows its kind at %C");
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
@ -625,7 +623,7 @@ cleanup:
/* Match a substring reference. */
static match
match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
match_substring (gfc_charlen *cl, int init, gfc_ref **result)
{
gfc_expr *start, *end;
locus old_loc;
@ -848,7 +846,7 @@ match_charkind_name (char *name)
delimiter. Using match_kind_param() generates errors too quickly. */
static match
match_string_constant (gfc_expr ** result)
match_string_constant (gfc_expr **result)
{
char *p, name[GFC_MAX_SYMBOL_LEN + 1];
int i, c, kind, length, delimiter;
@ -1002,7 +1000,7 @@ no_match:
/* Match a .true. or .false. */
static match
match_logical_constant (gfc_expr ** result)
match_logical_constant (gfc_expr **result)
{
static mstring logical_ops[] = {
minit (".false.", 0),
@ -1043,7 +1041,7 @@ match_logical_constant (gfc_expr ** result)
symbolic constant. */
static match
match_sym_complex_part (gfc_expr ** result)
match_sym_complex_part (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
@ -1101,7 +1099,7 @@ match_sym_complex_part (gfc_expr ** result)
gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
}
*result = e; /* e is a scalar, real, constant expression */
*result = e; /* e is a scalar, real, constant expression. */
return MATCH_YES;
error:
@ -1113,7 +1111,7 @@ error:
/* Match a real or imaginary part of a complex number. */
static match
match_complex_part (gfc_expr ** result)
match_complex_part (gfc_expr **result)
{
match m;
@ -1132,7 +1130,7 @@ match_complex_part (gfc_expr ** result)
/* Try to match a complex constant. */
static match
match_complex_constant (gfc_expr ** result)
match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
gfc_error_buf old_error;
@ -1249,7 +1247,7 @@ cleanup:
match, zero for no match. */
match
gfc_match_literal_constant (gfc_expr ** result, int signflag)
gfc_match_literal_constant (gfc_expr **result, int signflag)
{
match m;
@ -1293,7 +1291,7 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag)
fixing things later during resolution. */
static match
match_actual_arg (gfc_expr ** result)
match_actual_arg (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *symtree;
@ -1325,18 +1323,18 @@ match_actual_arg (gfc_expr ** result)
/* Handle error elsewhere. */
/* Eliminate a couple of common cases where we know we don't
have a function argument. */
have a function argument. */
if (symtree == NULL)
{
{
gfc_get_sym_tree (name, NULL, &symtree);
gfc_set_sym_referenced (symtree->n.sym);
}
gfc_set_sym_referenced (symtree->n.sym);
}
else
{
gfc_symbol *sym;
gfc_symbol *sym;
sym = symtree->n.sym;
gfc_set_sym_referenced (sym);
sym = symtree->n.sym;
gfc_set_sym_referenced (sym);
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
break;
@ -1384,7 +1382,7 @@ match_actual_arg (gfc_expr ** result)
/* Match a keyword argument. */
static match
match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
@ -1413,9 +1411,8 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0)
{
gfc_error
("Keyword '%s' at %C has already appeared in the current "
"argument list", name);
gfc_error ("Keyword '%s' at %C has already appeared in the "
"current argument list", name);
return MATCH_ERROR;
}
}
@ -1455,19 +1452,19 @@ match_arg_list_function (gfc_actual_arglist *result)
switch (name[0])
{
case 'l':
if (strncmp(name, "loc", 3) == 0)
if (strncmp (name, "loc", 3) == 0)
{
result->name = "%LOC";
break;
}
case 'r':
if (strncmp(name, "ref", 3) == 0)
if (strncmp (name, "ref", 3) == 0)
{
result->name = "%REF";
break;
}
case 'v':
if (strncmp(name, "val", 3) == 0)
if (strncmp (name, "val", 3) == 0)
{
result->name = "%VAL";
break;
@ -1511,7 +1508,7 @@ cleanup:
we're matching the argument list of a subroutine. */
match
gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
@ -1554,7 +1551,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
}
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
arguments must also have keywords. */
if (seen_keyword)
{
m = match_keyword_arg (tail, head);
@ -1563,8 +1560,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
goto cleanup;
if (m == MATCH_NO)
{
gfc_error
("Missing keyword name in actual argument list at %C");
gfc_error ("Missing keyword name in actual argument list at %C");
goto cleanup;
}
@ -1623,9 +1619,8 @@ cleanup:
element. */
static gfc_ref *
extend_ref (gfc_expr * primary, gfc_ref * tail)
extend_ref (gfc_expr *primary, gfc_ref *tail)
{
if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref ();
else
@ -1646,7 +1641,7 @@ extend_ref (gfc_expr * primary, gfc_ref * tail)
statement. */
static match
match_varspec (gfc_expr * primary, int equiv_flag)
match_varspec (gfc_expr *primary, int equiv_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
@ -1656,13 +1651,11 @@ match_varspec (gfc_expr * primary, int equiv_flag)
tail = NULL;
if ((equiv_flag && gfc_peek_char () == '(')
|| sym->attr.dimension)
if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
variables. We'll leave the decision till resolve
time. */
variables. We'll leave the decision till resolve time. */
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
@ -1734,8 +1727,8 @@ check_substring:
{
if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
{
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
}
}
@ -1787,7 +1780,7 @@ check_substring:
We can have at most one full array reference. */
symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
int dimension, pointer, allocatable, target;
symbol_attribute attr;
@ -1865,7 +1858,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
/* Return the attribute from a general expression. */
symbol_attribute
gfc_expr_attr (gfc_expr * e)
gfc_expr_attr (gfc_expr *e)
{
symbol_attribute attr;
@ -1882,7 +1875,7 @@ gfc_expr_attr (gfc_expr * e)
attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this
here. */
here. */
break;
@ -1899,7 +1892,7 @@ gfc_expr_attr (gfc_expr * e)
seen. */
match
gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
gfc_constructor *head, *tail;
gfc_component *comp;
@ -1936,8 +1929,7 @@ gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
{
if (comp->next == NULL)
{
gfc_error
("Too many components in structure constructor at %C");
gfc_error ("Too many components in structure constructor at %C");
goto cleanup;
}
@ -1982,7 +1974,7 @@ cleanup:
array reference, argument list of a function, etc. */
match
gfc_match_rvalue (gfc_expr ** result)
gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
@ -2020,8 +2012,8 @@ gfc_match_rvalue (gfc_expr ** result)
/* See if this is a directly recursive function call. */
gfc_gobble_whitespace ();
if (sym->attr.recursive
&& gfc_peek_char () == '('
&& gfc_current_ns->proc_name == sym)
&& gfc_peek_char () == '('
&& gfc_current_ns->proc_name == sym)
{
if (!sym->attr.dimension)
goto function0;
@ -2093,7 +2085,7 @@ gfc_match_rvalue (gfc_expr ** result)
if (sym == NULL)
m = MATCH_ERROR;
else
m = gfc_match_structure_constructor (sym, &e);
m = gfc_match_structure_constructor (sym, &e);
break;
/* If we're here, then the name is known to be the name of a
@ -2108,9 +2100,9 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* At this point, the name has to be a non-statement function.
If the name is the same as the current function being
compiled, then we have a variable reference (to the function
result) if the name is non-recursive. */
If the name is the same as the current function being
compiled, then we have a variable reference (to the function
result) if the name is non-recursive. */
st = gfc_enclosing_unit (NULL);
@ -2176,8 +2168,8 @@ gfc_match_rvalue (gfc_expr ** result)
case FL_UNKNOWN:
/* Special case for derived type variables that get their types
via an IMPLICIT statement. This can't wait for the
resolution phase. */
via an IMPLICIT statement. This can't wait for the
resolution phase. */
if (gfc_peek_char () == '%'
&& sym->ts.type == BT_UNKNOWN
@ -2185,7 +2177,7 @@ gfc_match_rvalue (gfc_expr ** result)
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
variable. */
variable. */
if (sym->attr.dimension)
{
@ -2204,8 +2196,8 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* Name is not an array, so we peek to see if a '(' implies a
function call or a substring reference. Otherwise the
variable is just a scalar. */
function call or a substring reference. Otherwise the
variable is just a scalar. */
gfc_gobble_whitespace ();
if (gfc_peek_char () != '(')
@ -2310,7 +2302,7 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
type, it might have subsequent references. */
m = match_varspec (e, 0);
if (m == MATCH_NO)
@ -2357,7 +2349,7 @@ gfc_match_rvalue (gfc_expr ** result)
match of the symbol to the local scope. */
static match
match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
match_variable (gfc_expr **result, int equiv_flag, int host_flag)
{
gfc_symbol *sym;
gfc_symtree *st;
@ -2387,10 +2379,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
{
case FL_VARIABLE:
if (sym->attr.protected && sym->attr.use_assoc)
{
{
gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR;
}
return MATCH_ERROR;
}
break;
case FL_UNKNOWN:
@ -2464,14 +2456,16 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
return MATCH_YES;
}
match
gfc_match_variable (gfc_expr ** result, int equiv_flag)
gfc_match_variable (gfc_expr **result, int equiv_flag)
{
return match_variable (result, equiv_flag, 1);
}
match
gfc_match_equiv_variable (gfc_expr ** result)
gfc_match_equiv_variable (gfc_expr **result)
{
return match_variable (result, 1, 0);
}

1544
gcc/fortran/resolve.c
View File

File diff suppressed because it is too large Load Diff

57
gcc/fortran/scanner.c
View File

@ -113,7 +113,6 @@ gfc_scanner_done_1 (void)
gfc_free(file_head);
file_head = f;
}
}
@ -248,12 +247,12 @@ gfc_open_intrinsic_module (const char *name)
return open_included_file (name, intrinsic_modules_dirs, true);
}
/* Test to see if we're at the end of the main source file. */
int
gfc_at_end (void)
{
return end_flag;
}
@ -263,7 +262,6 @@ gfc_at_end (void)
int
gfc_at_eof (void)
{
if (gfc_at_end ())
return 1;
@ -294,7 +292,6 @@ gfc_at_bol (void)
int
gfc_at_eol (void)
{
if (gfc_at_eof ())
return 1;
@ -318,7 +315,7 @@ gfc_advance_line (void)
gfc_current_locus.lb = gfc_current_locus.lb->next;
if (gfc_current_locus.lb != NULL)
if (gfc_current_locus.lb != NULL)
gfc_current_locus.nextc = gfc_current_locus.lb->line;
else
{
@ -355,6 +352,7 @@ next_char (void)
return c;
}
/* Skip a comment. When we come here the parse pointer is positioned
immediately after the comment character. If we ever implement
compiler directives withing comments, here is where we parse the
@ -714,10 +712,9 @@ restart:
{
if (++continue_count == gfc_option.max_continue_free)
{
if (gfc_notification_std (GFC_STD_GNU)
|| pedantic)
gfc_warning ("Limit of %d continuations exceeded in statement at %C",
gfc_option.max_continue_free);
if (gfc_notification_std (GFC_STD_GNU) || pedantic)
gfc_warning ("Limit of %d continuations exceeded in "
"statement at %C", gfc_option.max_continue_free);
}
}
continue_line = gfc_current_locus.lb->linenum;
@ -761,7 +758,8 @@ restart:
if (in_string)
{
if (gfc_option.warn_ampersand)
gfc_warning_now ("Missing '&' in continued character constant at %C");
gfc_warning_now ("Missing '&' in continued character "
"constant at %C");
gfc_current_locus.nextc--;
}
/* Both !$omp and !$ -fopenmp continuation lines have & on the
@ -835,10 +833,10 @@ restart:
{
if (++continue_count == gfc_option.max_continue_fixed)
{
if (gfc_notification_std (GFC_STD_GNU)
|| pedantic)
gfc_warning ("Limit of %d continuations exceeded in statement at %C",
gfc_option.max_continue_fixed);
if (gfc_notification_std (GFC_STD_GNU) || pedantic)
gfc_warning ("Limit of %d continuations exceeded in "
"statement at %C",
gfc_option.max_continue_fixed);
}
}
@ -997,7 +995,7 @@ gfc_gobble_whitespace (void)
parts of gfortran. */
static int
load_line (FILE * input, char **pbuf, int *pbuflen)
load_line (FILE *input, char **pbuf, int *pbuflen)
{
static int linenum = 0, current_line = 1;
int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
@ -1052,11 +1050,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& !seen_printable && seen_ampersand)
{
if (pedantic)
gfc_error_now
("'&' not allowed by itself in line %d", current_line);
gfc_error_now ("'&' not allowed by itself in line %d",
current_line);
else
gfc_warning_now
("'&' not allowed by itself in line %d", current_line);
gfc_warning_now ("'&' not allowed by itself in line %d",
current_line);
}
break;
}
@ -1084,11 +1082,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& c == '!' && !seen_printable && seen_ampersand)
{
if (pedantic)
gfc_error_now (
"'&' not allowed by itself with comment in line %d", current_line);
gfc_error_now ("'&' not allowed by itself with comment in "
"line %d", current_line);
else
gfc_warning_now (
"'&' not allowed by itself with comment in line %d", current_line);
gfc_warning_now ("'&' not allowed by itself with comment in "
"line %d", current_line);
seen_printable = 1;
}
@ -1103,8 +1101,8 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& current_line != linenum)
{
linenum = current_line;
gfc_warning_now (
"Nonconforming tab character in column 1 of line %d", linenum);
gfc_warning_now ("Nonconforming tab character in column 1 "
"of line %d", linenum);
}
while (i <= 6)
@ -1127,7 +1125,7 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
overlong line. */
buflen = buflen * 2;
*pbuf = xrealloc (*pbuf, buflen + 1);
buffer = (*pbuf)+i;
buffer = (*pbuf) + i;
}
}
else if (i >= maxlen)
@ -1234,10 +1232,10 @@ preprocessor_line (char *c)
/* Make filename end at quote. */
unescape = 0;
escaped = false;
while (*c && ! (! escaped && *c == '"'))
while (*c && ! (!escaped && *c == '"'))
{
if (escaped)
escaped = false;
escaped = false;
else if (*c == '\\')
{
escaped = true;
@ -1407,6 +1405,7 @@ include_line (char *line)
return true;
}
/* Load a file into memory by calling load_line until the file ends. */
static try
@ -1582,7 +1581,7 @@ unescape_filename (const char *ptr)
++p;
}
if (! *p || p[1])
if (!*p || p[1])
return NULL;
/* Undo effects of cpp_quote_string. */

499
gcc/fortran/simplify.c
View File

File diff suppressed because it is too large Load Diff

13
gcc/fortran/st.c
View File

@ -1,5 +1,5 @@
/* Build executable statement trees.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -37,7 +37,6 @@ gfc_code new_st;
void
gfc_clear_new_st (void)
{
memset (&new_st, '\0', sizeof (new_st));
new_st.op = EXEC_NOP;
}
@ -60,9 +59,8 @@ gfc_get_code (void)
its tail, returning a pointer to the new tail. */
gfc_code *
gfc_append_code (gfc_code * tail, gfc_code * new)
gfc_append_code (gfc_code *tail, gfc_code *new)
{
if (tail != NULL)
{
while (tail->next != NULL)
@ -81,9 +79,8 @@ gfc_append_code (gfc_code * tail, gfc_code * new)
/* Free a single code structure, but not the actual structure itself. */
void
gfc_free_statement (gfc_code * p)
gfc_free_statement (gfc_code *p)
{
if (p->expr)
gfc_free_expr (p->expr);
if (p->expr2)
@ -157,7 +154,7 @@ gfc_free_statement (gfc_code * p)
case EXEC_DT_END:
/* The ext.dt member is a duplicate pointer and doesn't need to
be freed. */
be freed. */
break;
case EXEC_FORALL:
@ -200,7 +197,7 @@ gfc_free_statement (gfc_code * p)
/* Free a code statement and all other code structures linked to it. */
void
gfc_free_statements (gfc_code * p)
gfc_free_statements (gfc_code *p)
{
gfc_code *q;