Skip to content

R
riscv-gcc-1
Commit edf1eac2 by Steven G. Kargl
Options

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

    * 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
parent 70fadd09
Showing with 1623 additions and 1714 deletions
gcc/fortran/ChangeLog
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
......
gcc/fortran/matchexp.c
/* 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;
......
gcc/fortran/misc.c
/* 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 ();
}
......
gcc/fortran/module.c
/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
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.
......@@ -199,7 +199,7 @@ static bool in_load_equiv;
/* Recursively free the tree of pointer structures. */
static void
free_pi_tree (pointer_info * p)
free_pi_tree (pointer_info *p)
{
if (p == NULL)
return;
......@@ -218,7 +218,7 @@ free_pi_tree (pointer_info * p)
module. */
static int
compare_pointers (void * _sn1, void * _sn2)
compare_pointers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
......@@ -238,7 +238,7 @@ compare_pointers (void * _sn1, void * _sn2)
module. */
static int
compare_integers (void * _sn1, void * _sn2)
compare_integers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
......@@ -366,7 +366,7 @@ get_integer (int integer)
/* Recursive function to find a pointer within a tree by brute force. */
static pointer_info *
fp2 (pointer_info * p, const void *target)
fp2 (pointer_info *p, const void *target)
{
pointer_info *q;
......@@ -390,14 +390,13 @@ fp2 (pointer_info * p, const void *target)
static pointer_info *
find_pointer2 (void *p)
{
return fp2 (pi_root, p);
}
/* Resolve any fixups using a known pointer. */
static void
resolve_fixups (fixup_t *f, void * gp)
resolve_fixups (fixup_t *f, void *gp)
{
fixup_t *next;
......@@ -409,12 +408,13 @@ resolve_fixups (fixup_t *f, void * gp)
}
}
/* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at
this time. */
static void
associate_integer_pointer (pointer_info * p, void *gp)
associate_integer_pointer (pointer_info *p, void *gp)
{
if (p->u.pointer != NULL)
gfc_internal_error ("associate_integer_pointer(): Already associated");
......@@ -577,7 +577,7 @@ gfc_match_use (void)
tail = new;
/* See what kind of interface we're dealing with. Assume it is
not an operator. */
not an operator. */
new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
goto cleanup;
......@@ -681,6 +681,7 @@ find_use_name_n (const char *name, int *inst)
return (u->local_name[0] != '\0') ? u->local_name : name;
}
/* Given a name, return the name under which to load this symbol.
Returns NULL if this symbol shouldn't be loaded. */
......@@ -691,8 +692,8 @@ find_use_name (const char *name)
return find_use_name_n (name, &i);
}
/* Given a real name, return the number of use names associated
with it. */
/* Given a real name, return the number of use names associated with it. */
static int
number_use_names (const char *name)
......@@ -745,7 +746,7 @@ static true_name *true_name_root;
/* Compare two true_name structures. */
static int
compare_true_names (void * _t1, void * _t2)
compare_true_names (void *_t1, void *_t2)
{
true_name *t1, *t2;
int c;
......@@ -782,7 +783,7 @@ find_true_name (const char *name, const char *module)
p = true_name_root;
while (p != NULL)
{
c = compare_true_names ((void *)(&t), (void *) p);
c = compare_true_names ((void *) (&t), (void *) p);
if (c == 0)
return p->sym;
......@@ -793,11 +794,10 @@ find_true_name (const char *name, const char *module)
}
/* Given a gfc_symbol pointer that is not in the true name tree, add
it. */
/* Given a gfc_symbol pointer that is not in the true name tree, add it. */
static void
add_true_name (gfc_symbol * sym)
add_true_name (gfc_symbol *sym)
{
true_name *t;
......@@ -812,9 +812,8 @@ add_true_name (gfc_symbol * sym)
recursively traversing the current namespace. */
static void
build_tnt (gfc_symtree * st)
build_tnt (gfc_symtree *st)
{
if (st == NULL)
return;
......@@ -834,7 +833,6 @@ static void
init_true_name_tree (void)
{
true_name_root = NULL;
build_tnt (gfc_current_ns->sym_root);
}
......@@ -842,9 +840,8 @@ init_true_name_tree (void)
/* Recursively free a true name tree node. */
static void
free_true_name (true_name * t)
free_true_name (true_name *t)
{
if (t == NULL)
return;
free_true_name (t->left);
......@@ -911,9 +908,8 @@ bad_module (const char *msgid)
/* Set the module's input pointer. */
static void
set_module_locus (module_locus * m)
set_module_locus (module_locus *m)
{
module_column = m->column;
module_line = m->line;
fsetpos (module_fp, &m->pos);
......@@ -923,9 +919,8 @@ set_module_locus (module_locus * m)
/* Get the module's input pointer so that we can restore it later. */
static void
get_module_locus (module_locus * m)
get_module_locus (module_locus *m)
{
m->column = module_column;
m->line = module_line;
fgetpos (module_fp, &m->pos);
......@@ -978,14 +973,14 @@ parse_string (void)
bad_module ("Unexpected end of module in string constant");
if (c != '\'')
{
{
len++;
continue;
}
c = module_char ();
if (c == '\'')
{
{
len++;
continue;
}
......@@ -1001,12 +996,12 @@ parse_string (void)
{
c = module_char ();
if (c == '\'')
module_char (); /* Guaranteed to be another \' */
module_char (); /* Guaranteed to be another \' */
*p++ = c;
}
module_char (); /* Terminating \' */
*p = '\0'; /* C-style string for debug purposes */
module_char (); /* Terminating \' */
*p = '\0'; /* C-style string for debug purposes. */
}
......@@ -1239,7 +1234,7 @@ require_atom (atom_type type)
be one of the strings in the array. We return the enum value. */
static int
find_enum (const mstring * m)
find_enum (const mstring *m)
{
int i;
......@@ -1260,7 +1255,6 @@ find_enum (const mstring * m)
static void
write_char (char out)
{
if (fputc (out, module_fp) == EOF)
gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
......@@ -1362,9 +1356,8 @@ static void mio_symtree_ref (gfc_symtree **);
pointer because enums are sometimes inside bitfields. */
static int
mio_name (int t, const mstring * m)
mio_name (int t, const mstring *m)
{
if (iomode == IO_OUTPUT)
write_atom (ATOM_NAME, gfc_code2string (m, t));
else
......@@ -1380,16 +1373,15 @@ mio_name (int t, const mstring * m)
#define DECL_MIO_NAME(TYPE) \
static inline TYPE \
MIO_NAME(TYPE) (TYPE t, const mstring * m) \
MIO_NAME(TYPE) (TYPE t, const mstring *m) \
{ \
return (TYPE)mio_name ((int)t, m); \
return (TYPE) mio_name ((int) t, m); \
}
#define MIO_NAME(TYPE) mio_name_##TYPE
static void
mio_lparen (void)
{
if (iomode == IO_OUTPUT)
write_atom (ATOM_LPAREN, NULL);
else
......@@ -1400,7 +1392,6 @@ mio_lparen (void)
static void
mio_rparen (void)
{
if (iomode == IO_OUTPUT)
write_atom (ATOM_RPAREN, NULL);
else
......@@ -1411,7 +1402,6 @@ mio_rparen (void)
static void
mio_integer (int *ip)
{
if (iomode == IO_OUTPUT)
write_atom (ATOM_INTEGER, ip);
else
......@@ -1472,7 +1462,6 @@ mio_pool_string (const char **stringp)
static void
mio_internal_string (char *string)
{
if (iomode == IO_OUTPUT)
write_atom (ATOM_STRING, string);
else
......@@ -1529,18 +1518,18 @@ static const mstring attr_bits[] =
};
/* Specialization of mio_name. */
DECL_MIO_NAME(ab_attribute)
DECL_MIO_NAME(ar_type)
DECL_MIO_NAME(array_type)
DECL_MIO_NAME(bt)
DECL_MIO_NAME(expr_t)
DECL_MIO_NAME(gfc_access)
DECL_MIO_NAME(gfc_intrinsic_op)
DECL_MIO_NAME(ifsrc)
DECL_MIO_NAME(procedure_type)
DECL_MIO_NAME(ref_type)
DECL_MIO_NAME(sym_flavor)
DECL_MIO_NAME(sym_intent)
DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME (ar_type)
DECL_MIO_NAME (array_type)
DECL_MIO_NAME (bt)
DECL_MIO_NAME (expr_t)
DECL_MIO_NAME (gfc_access)
DECL_MIO_NAME (gfc_intrinsic_op)
DECL_MIO_NAME (ifsrc)
DECL_MIO_NAME (procedure_type)
DECL_MIO_NAME (ref_type)
DECL_MIO_NAME (sym_flavor)
DECL_MIO_NAME (sym_intent)
#undef DECL_MIO_NAME
/* Symbol attributes are stored in list with the first three elements
......@@ -1550,86 +1539,85 @@ DECL_MIO_NAME(sym_intent)
written. */
static void
mio_symbol_attribute (symbol_attribute * attr)
mio_symbol_attribute (symbol_attribute *attr)
{
atom_type t;
mio_lparen ();
attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
if (iomode == IO_OUTPUT)
{
if (attr->allocatable)
MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
if (attr->dimension)
MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->external)
MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
if (attr->intrinsic)
MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
if (attr->optional)
MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
if (attr->pointer)
MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
if (attr->protected)
MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits);
MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
if (attr->save)
MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
if (attr->value)
MIO_NAME(ab_attribute) (AB_VALUE, attr_bits);
MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
if (attr->volatile_)
MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits);
MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
if (attr->target)
MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
if (attr->threadprivate)
MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result)
MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
/* We deliberately don't preserve the "entry" flag. */
if (attr->data)
MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
if (attr->in_namelist)
MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
if (attr->in_common)
MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
if (attr->function)
MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
if (attr->subroutine)
MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
if (attr->generic)
MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
if (attr->sequence)
MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
if (attr->elemental)
MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure)
MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->recursive)
MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
if (attr->cray_pointer)
MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
if (attr->cray_pointee)
MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
if (attr->alloc_comp)
MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
mio_rparen ();
}
else
{
for (;;)
{
t = parse_atom ();
......@@ -1712,9 +1700,9 @@ mio_symbol_attribute (symbol_attribute * attr)
case AB_RECURSIVE:
attr->recursive = 1;
break;
case AB_ALWAYS_EXPLICIT:
attr->always_explicit = 1;
break;
case AB_ALWAYS_EXPLICIT:
attr->always_explicit = 1;
break;
case AB_CRAY_POINTER:
attr->cray_pointer = 1;
break;
......@@ -1744,7 +1732,7 @@ static const mstring bt_types[] = {
static void
mio_charlen (gfc_charlen ** clp)
mio_charlen (gfc_charlen **clp)
{
gfc_charlen *cl;
......@@ -1758,7 +1746,6 @@ mio_charlen (gfc_charlen ** clp)
}
else
{
if (peek_atom () != ATOM_RPAREN)
{
cl = gfc_get_charlen ();
......@@ -1779,7 +1766,7 @@ mio_charlen (gfc_charlen ** clp)
within the namespace and corresponds to an illegal fortran name. */
static gfc_symtree *
get_unique_symtree (gfc_namespace * ns)
get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
......@@ -1794,18 +1781,16 @@ get_unique_symtree (gfc_namespace * ns)
static int
check_unique_name (const char *name)
{
return *name == '@';
}
static void
mio_typespec (gfc_typespec * ts)
mio_typespec (gfc_typespec *ts)
{
mio_lparen ();
ts->type = MIO_NAME(bt) (ts->type, bt_types);
ts->type = MIO_NAME (bt) (ts->type, bt_types);
if (ts->type != BT_DERIVED)
mio_integer (&ts->kind);
......@@ -1828,7 +1813,7 @@ static const mstring array_spec_types[] = {
static void
mio_array_spec (gfc_array_spec ** asp)
mio_array_spec (gfc_array_spec **asp)
{
gfc_array_spec *as;
int i;
......@@ -1853,7 +1838,7 @@ mio_array_spec (gfc_array_spec ** asp)
}
mio_integer (&as->rank);
as->type = MIO_NAME(array_type) (as->type, array_spec_types);
as->type = MIO_NAME (array_type) (as->type, array_spec_types);
for (i = 0; i < as->rank; i++)
{
......@@ -1879,13 +1864,14 @@ static const mstring array_ref_types[] = {
minit (NULL, -1)
};
static void
mio_array_ref (gfc_array_ref * ar)
mio_array_ref (gfc_array_ref *ar)
{
int i;
mio_lparen ();
ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
mio_integer (&ar->dimen);
switch (ar->type)
......@@ -1976,7 +1962,7 @@ mio_pointer_ref (void *gp)
the namespace and is not loaded again. */
static void
mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
mio_component_ref (gfc_component **cp, gfc_symbol *sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_component *q;
......@@ -2020,7 +2006,7 @@ mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
static void
mio_component (gfc_component * c)
mio_component (gfc_component *c)
{
pointer_info *p;
int n;
......@@ -2056,7 +2042,7 @@ mio_component (gfc_component * c)
static void
mio_component_list (gfc_component ** cp)
mio_component_list (gfc_component **cp)
{
gfc_component *c, *tail;
......@@ -2069,7 +2055,6 @@ mio_component_list (gfc_component ** cp)
}
else
{
*cp = NULL;
tail = NULL;
......@@ -2095,9 +2080,8 @@ mio_component_list (gfc_component ** cp)
static void
mio_actual_arg (gfc_actual_arglist * a)
mio_actual_arg (gfc_actual_arglist *a)
{
mio_lparen ();
mio_pool_string (&a->name);
mio_expr (&a->expr);
......@@ -2106,7 +2090,7 @@ mio_actual_arg (gfc_actual_arglist * a)
static void
mio_actual_arglist (gfc_actual_arglist ** ap)
mio_actual_arglist (gfc_actual_arglist **ap)
{
gfc_actual_arglist *a, *tail;
......@@ -2146,7 +2130,7 @@ mio_actual_arglist (gfc_actual_arglist ** ap)
/* Read and write formal argument lists. */
static void
mio_formal_arglist (gfc_symbol * sym)
mio_formal_arglist (gfc_symbol *sym)
{
gfc_formal_arglist *f, *tail;
......@@ -2183,7 +2167,7 @@ mio_formal_arglist (gfc_symbol * sym)
/* Save or restore a reference to a symbol node. */
void
mio_symbol_ref (gfc_symbol ** symp)
mio_symbol_ref (gfc_symbol **symp)
{
pointer_info *p;
......@@ -2207,7 +2191,7 @@ mio_symbol_ref (gfc_symbol ** symp)
/* Save or restore a reference to a symtree node. */
static void
mio_symtree_ref (gfc_symtree ** stp)
mio_symtree_ref (gfc_symtree **stp)
{
pointer_info *p;
fixup_t *f;
......@@ -2224,29 +2208,30 @@ mio_symtree_ref (gfc_symtree ** stp)
return;
if (p->type == P_UNKNOWN)
p->type = P_SYMBOL;
p->type = P_SYMBOL;
if (p->u.rsym.state == UNUSED)
p->u.rsym.state = NEEDED;
if (p->u.rsym.symtree != NULL)
{
*stp = p->u.rsym.symtree;
}
{
*stp = p->u.rsym.symtree;
}
else
{
f = gfc_getmem (sizeof (fixup_t));
{
f = gfc_getmem (sizeof (fixup_t));
f->next = p->u.rsym.stfixup;
p->u.rsym.stfixup = f;
f->next = p->u.rsym.stfixup;
p->u.rsym.stfixup = f;
f->pointer = (void **)stp;
}
f->pointer = (void **)stp;
}
}
}
static void
mio_iterator (gfc_iterator ** ip)
mio_iterator (gfc_iterator **ip)
{
gfc_iterator *iter;
......@@ -2280,9 +2265,8 @@ done:
}
static void
mio_constructor (gfc_constructor ** cp)
mio_constructor (gfc_constructor **cp)
{
gfc_constructor *c, *tail;
......@@ -2300,7 +2284,6 @@ mio_constructor (gfc_constructor ** cp)
}
else
{
*cp = NULL;
tail = NULL;
......@@ -2326,7 +2309,6 @@ mio_constructor (gfc_constructor ** cp)
}
static const mstring ref_types[] = {
minit ("ARRAY", REF_ARRAY),
minit ("COMPONENT", REF_COMPONENT),
......@@ -2336,14 +2318,14 @@ static const mstring ref_types[] = {
static void
mio_ref (gfc_ref ** rp)
mio_ref (gfc_ref **rp)
{
gfc_ref *r;
mio_lparen ();
r = *rp;
r->type = MIO_NAME(ref_type) (r->type, ref_types);
r->type = MIO_NAME (ref_type) (r->type, ref_types);
switch (r->type)
{
......@@ -2368,7 +2350,7 @@ mio_ref (gfc_ref ** rp)
static void
mio_ref_list (gfc_ref ** rp)
mio_ref_list (gfc_ref **rp)
{
gfc_ref *ref, *head, *tail;
......@@ -2406,7 +2388,7 @@ mio_ref_list (gfc_ref ** rp)
/* Read and write an integer value. */
static void
mio_gmp_integer (mpz_t * integer)
mio_gmp_integer (mpz_t *integer)
{
char *p;
......@@ -2420,7 +2402,6 @@ mio_gmp_integer (mpz_t * integer)
bad_module ("Error converting integer");
gfc_free (atom_string);
}
else
{
......@@ -2432,7 +2413,7 @@ mio_gmp_integer (mpz_t * integer)
static void
mio_gmp_real (mpfr_t * real)
mio_gmp_real (mpfr_t *real)
{
mp_exp_t exponent;
char *p;
......@@ -2445,7 +2426,6 @@ mio_gmp_real (mpfr_t * real)
mpfr_init (*real);
mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string);
}
else
{
......@@ -2473,7 +2453,7 @@ mio_gmp_real (mpfr_t * real)
/* Save and restore the shape of an array constructor. */
static void
mio_shape (mpz_t ** pshape, int rank)
mio_shape (mpz_t **pshape, int rank)
{
mpz_t *shape;
atom_type t;
......@@ -2573,13 +2553,13 @@ fix_mio_expr (gfc_expr *e)
yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name(e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
e->symtree->n.sym->name);
e->symtree->n.sym->name);
/* On the other hand, if the existing symbol is the module name or the
new symbol is a dummy argument, do not do the promotion. */
if (ns_st && ns_st->n.sym
&& ns_st->n.sym->attr.flavor != FL_MODULE
&& !e->symtree->n.sym->attr.dummy)
&& ns_st->n.sym->attr.flavor != FL_MODULE
&& !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st;
}
else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
......@@ -2588,8 +2568,8 @@ fix_mio_expr (gfc_expr *e)
expression, in one use associated module, can fail to be
coupled to its symtree when used in a specification
expression in another module. */
fname = e->value.function.esym ? e->value.function.esym->name :
e->value.function.isym->name;
fname = e->value.function.esym ? e->value.function.esym->name
: e->value.function.isym->name;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
}
}
......@@ -2599,7 +2579,7 @@ fix_mio_expr (gfc_expr *e)
NULL expression. */
static void
mio_expr (gfc_expr ** ep)
mio_expr (gfc_expr **ep)
{
gfc_expr *e;
atom_type t;
......@@ -2616,8 +2596,7 @@ mio_expr (gfc_expr ** ep)
}
e = *ep;
MIO_NAME(expr_t) (e->expr_type, expr_types);
MIO_NAME (expr_t) (e->expr_type, expr_types);
}
else
{
......@@ -2645,7 +2624,7 @@ mio_expr (gfc_expr ** ep)
{
case EXPR_OP:
e->value.op.operator
= MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
= MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
switch (e->value.op.operator)
{
......@@ -2696,7 +2675,6 @@ mio_expr (gfc_expr ** ep)
mio_symbol_ref (&e->value.function.esym);
else
write_atom (ATOM_STRING, e->value.function.isym->name);
}
else
{
......@@ -2723,8 +2701,8 @@ mio_expr (gfc_expr ** ep)
break;
case EXPR_SUBSTRING:
e->value.character.string = (char *)
mio_allocated_string (e->value.character.string);
e->value.character.string
= (char *) mio_allocated_string (e->value.character.string);
mio_ref_list (&e->ref);
break;
......@@ -2742,12 +2720,12 @@ mio_expr (gfc_expr ** ep)
break;
case BT_REAL:
gfc_set_model_kind (e->ts.kind);
gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real);
break;
case BT_COMPLEX:
gfc_set_model_kind (e->ts.kind);
gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.complex.r);
mio_gmp_real (&e->value.complex.i);
break;
......@@ -2758,8 +2736,8 @@ mio_expr (gfc_expr ** ep)
case BT_CHARACTER:
mio_integer (&e->value.character.length);
e->value.character.string = (char *)
mio_allocated_string (e->value.character.string);
e->value.character.string
= (char *) mio_allocated_string (e->value.character.string);
break;
default:
......@@ -2779,7 +2757,7 @@ mio_expr (gfc_expr ** ep)
/* Read and write namelists */
static void
mio_namelist (gfc_symbol * sym)
mio_namelist (gfc_symbol *sym)
{
gfc_namelist *n, *m;
const char *check_name;
......@@ -2800,9 +2778,8 @@ mio_namelist (gfc_symbol * sym)
{
check_name = find_use_name (sym->name);
if (check_name && strcmp (check_name, sym->name) != 0)
gfc_error("Namelist %s cannot be renamed by USE"
" association to %s",
sym->name, check_name);
gfc_error ("Namelist %s cannot be renamed by USE "
"association to %s", sym->name, check_name);
}
m = NULL;
......@@ -2831,7 +2808,7 @@ mio_namelist (gfc_symbol * sym)
be done later when all symbols have been loaded. */
static void
mio_interface_rest (gfc_interface ** ip)
mio_interface_rest (gfc_interface **ip)
{
gfc_interface *tail, *p;
......@@ -2843,7 +2820,6 @@ mio_interface_rest (gfc_interface ** ip)
}
else
{
if (*ip == NULL)
tail = NULL;
else
......@@ -2878,9 +2854,8 @@ mio_interface_rest (gfc_interface ** ip)
/* Save/restore a nameless operator interface. */
static void
mio_interface (gfc_interface ** ip)
mio_interface (gfc_interface **ip)
{
mio_lparen ();
mio_interface_rest (ip);
}
......@@ -2890,20 +2865,17 @@ mio_interface (gfc_interface ** ip)
static void
mio_symbol_interface (const char **name, const char **module,
gfc_interface ** ip)
gfc_interface **ip)
{
mio_lparen ();
mio_pool_string (name);
mio_pool_string (module);
mio_interface_rest (ip);
}
static void
mio_namespace_ref (gfc_namespace ** nsp)
mio_namespace_ref (gfc_namespace **nsp)
{
gfc_namespace *ns;
pointer_info *p;
......@@ -2915,7 +2887,7 @@ mio_namespace_ref (gfc_namespace ** nsp)
if (iomode == IO_INPUT && p->integer != 0)
{
ns = (gfc_namespace *)p->u.pointer;
ns = (gfc_namespace *) p->u.pointer;
if (ns == NULL)
{
ns = gfc_get_namespace (NULL, 0);
......@@ -2927,12 +2899,11 @@ mio_namespace_ref (gfc_namespace ** nsp)
}
/* Unlike most other routines, the address of the symbol node is
already fixed on input and the name/module has already been filled
in. */
/* Unlike most other routines, the address of the symbol node is already
fixed on input and the name/module has already been filled in. */
static void
mio_symbol (gfc_symbol * sym)
mio_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
......@@ -2985,8 +2956,8 @@ mio_symbol (gfc_symbol * sym)
mio_component_list (&sym->components);
if (sym->components != NULL)
sym->component_access =
MIO_NAME(gfc_access) (sym->component_access, access_types);
sym->component_access
= MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym);
mio_rparen ();
......@@ -3096,7 +3067,7 @@ load_generic_interfaces (void)
if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
{
while (parse_atom () != ATOM_RPAREN);
continue;
continue;
}
if (sym == NULL)
......@@ -3139,9 +3110,9 @@ load_generic_interfaces (void)
/* Load common blocks. */
static void
load_commons(void)
load_commons (void)
{
char name[GFC_MAX_SYMBOL_LEN+1];
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *p;
mio_lparen ();
......@@ -3162,45 +3133,46 @@ load_commons(void)
p->threadprivate = 1;
p->use_assoc = 1;
mio_rparen();
mio_rparen ();
}
mio_rparen();
mio_rparen ();
}
/* load_equiv()-- Load equivalences. The flag in_load_equiv informs
mio_expr_ref of this so that unused variables are not loaded and
so that the expression can be safely freed.*/
static void
load_equiv(void)
load_equiv (void)
{
gfc_equiv *head, *tail, *end, *eq;
bool unused;
mio_lparen();
mio_lparen ();
in_load_equiv = true;
end = gfc_current_ns->equiv;
while(end != NULL && end->next != NULL)
while (end != NULL && end->next != NULL)
end = end->next;
while(peek_atom() != ATOM_RPAREN) {
mio_lparen();
while (peek_atom() != ATOM_RPAREN) {
mio_lparen ();
head = tail = NULL;
while(peek_atom() != ATOM_RPAREN)
while(peek_atom () != ATOM_RPAREN)
{
if (head == NULL)
head = tail = gfc_get_equiv();
head = tail = gfc_get_equiv ();
else
{
tail->eq = gfc_get_equiv();
tail->eq = gfc_get_equiv ();
tail = tail->eq;
}
mio_pool_string(&tail->module);
mio_expr(&tail->expr);
mio_pool_string (&tail->module);
mio_expr (&tail->expr);
}
/* Unused variables have no symtree. */
......@@ -3232,10 +3204,10 @@ load_equiv(void)
if (head != NULL)
end = head;
mio_rparen();
mio_rparen ();
}
mio_rparen();
mio_rparen ();
in_load_equiv = false;
}
......@@ -3244,7 +3216,7 @@ load_equiv(void)
traversal, because the act of loading can alter the tree. */
static int
load_needed (pointer_info * p)
load_needed (pointer_info *p)
{
gfc_namespace *ns;
pointer_info *q;
......@@ -3300,7 +3272,7 @@ load_needed (pointer_info * p)
read. */
static void
read_cleanup (pointer_info * p)
read_cleanup (pointer_info *p)
{
gfc_symtree *st;
pointer_info *q;
......@@ -3387,8 +3359,7 @@ read_module (void)
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
if (sym == NULL
|| (sym->attr.flavor == FL_VARIABLE
&& info->u.rsym.ns !=1))
|| (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
continue;
info->u.rsym.state = USED;
......@@ -3438,9 +3409,11 @@ read_module (void)
}
else
{
/* Create a symtree node in the current namespace for this symbol. */
st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
gfc_new_symtree (&gfc_current_ns->sym_root, p);
/* Create a symtree node in the current namespace for this
symbol. */
st = check_unique_name (p)
? get_unique_symtree (gfc_current_ns)
: gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;
......@@ -3449,10 +3422,9 @@ read_module (void)
/* Create a symbol node if it doesn't already exist. */
if (sym == NULL)
{
sym = info->u.rsym.sym =
gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns);
info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns);
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
}
......@@ -3463,7 +3435,7 @@ read_module (void)
info->u.rsym.symtree = st;
if (info->u.rsym.state == UNUSED)
info->u.rsym.state = NEEDED;
info->u.rsym.state = NEEDED;
info->u.rsym.referenced = 1;
}
}
......@@ -3508,7 +3480,7 @@ read_module (void)
load_generic_interfaces ();
load_commons ();
load_equiv();
load_equiv ();
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
......@@ -3516,8 +3488,7 @@ read_module (void)
while (load_needed (pi_root));
/* Make sure all elements of the rename-list were found in the
module. */
/* Make sure all elements of the rename-list were found in the module. */
for (u = gfc_rename_list; u; u = u->next)
{
......@@ -3533,15 +3504,14 @@ read_module (void)
if (u->operator == INTRINSIC_USER)
{
gfc_error
("User operator '%s' referenced at %L not found in module '%s'",
u->use_name, &u->where, module_name);
gfc_error ("User operator '%s' referenced at %L not found "
"in module '%s'", u->use_name, &u->where, module_name);
continue;
}
gfc_error
("Intrinsic operator '%s' referenced at %L not found in module "
"'%s'", gfc_op2string (u->operator), &u->where, module_name);
gfc_error ("Intrinsic operator '%s' referenced at %L not found "
"in module '%s'", gfc_op2string (u->operator), &u->where,
module_name);
}
gfc_check_interfaces (gfc_current_ns);
......@@ -3562,7 +3532,6 @@ read_module (void)
bool
gfc_check_access (gfc_access specific_access, gfc_access default_access)
{
if (specific_access == ACCESS_PUBLIC)
return TRUE;
if (specific_access == ACCESS_PRIVATE)
......@@ -3584,23 +3553,23 @@ write_common (gfc_symtree *st)
if (st == NULL)
return;
write_common(st->left);
write_common(st->right);
write_common (st->left);
write_common (st->right);
mio_lparen();
mio_lparen ();
/* Write the unmangled name. */
name = st->n.common->name;
mio_pool_string(&name);
mio_pool_string (&name);
p = st->n.common;
mio_symbol_ref(&p->head);
mio_symbol_ref (&p->head);
flags = p->saved ? 1 : 0;
if (p->threadprivate) flags |= 2;
mio_integer(&flags);
mio_integer (&flags);
mio_rparen();
mio_rparen ();
}
/* Write the blank common block to the module */
......@@ -3614,47 +3583,49 @@ write_blank_common (void)
if (gfc_current_ns->blank_common.head == NULL)
return;
mio_lparen();
mio_lparen ();
mio_pool_string(&name);
mio_pool_string (&name);
mio_symbol_ref(&gfc_current_ns->blank_common.head);
mio_symbol_ref (&gfc_current_ns->blank_common.head);
saved = gfc_current_ns->blank_common.saved;
mio_integer(&saved);
mio_integer (&saved);
mio_rparen();
mio_rparen ();
}
/* Write equivalences to the module. */
static void
write_equiv(void)
write_equiv (void)
{
gfc_equiv *eq, *e;
int num;
num = 0;
for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
{
mio_lparen();
mio_lparen ();
for(e=eq; e; e=e->eq)
for (e = eq; e; e = e->eq)
{
if (e->module == NULL)
e->module = gfc_get_string("%s.eq.%d", module_name, num);
mio_allocated_string(e->module);
mio_expr(&e->expr);
e->module = gfc_get_string ("%s.eq.%d", module_name, num);
mio_allocated_string (e->module);
mio_expr (&e->expr);
}
num++;
mio_rparen();
mio_rparen ();
}
}
/* Write a symbol to the module. */
static void
write_symbol (int n, gfc_symbol * sym)
write_symbol (int n, gfc_symbol *sym)
{
if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
......@@ -3676,7 +3647,7 @@ write_symbol (int n, gfc_symbol * sym)
according to the access specification. */
static void
write_symbol0 (gfc_symtree * st)
write_symbol0 (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
......@@ -3720,9 +3691,8 @@ write_symbol0 (gfc_symtree * st)
symbol was written and pass that information upwards. */
static int
write_symbol1 (pointer_info * p)
write_symbol1 (pointer_info *p)
{
if (p == NULL)
return 0;
......@@ -3744,7 +3714,7 @@ write_symbol1 (pointer_info * p)
/* Write operator interfaces associated with a symbol. */
static void
write_operator (gfc_user_op * uop)
write_operator (gfc_user_op *uop)
{
static char nullstring[] = "";
const char *p = nullstring;
......@@ -3760,9 +3730,8 @@ write_operator (gfc_user_op * uop)
/* Write generic interfaces associated with a symbol. */
static void
write_generic (gfc_symbol * sym)
write_generic (gfc_symbol *sym)
{
if (sym->generic == NULL
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
......@@ -3775,7 +3744,7 @@ write_generic (gfc_symbol * sym)
static void
write_symtree (gfc_symtree * st)
write_symtree (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
......@@ -3840,10 +3809,11 @@ write_module (void)
write_char ('\n');
write_char ('\n');
mio_lparen();
write_equiv();
mio_rparen();
write_char('\n'); write_char('\n');
mio_lparen ();
write_equiv ();
mio_rparen ();
write_char ('\n');
write_char ('\n');
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
......@@ -3935,8 +3905,8 @@ gfc_dump_module (const char *name, int dump_flag)
static void
create_int_parameter (const char *name, int value, const char *modname)
{
gfc_symtree * tmp_symtree;
gfc_symbol * sym;
gfc_symtree *tmp_symtree;
gfc_symbol *sym;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL)
......@@ -3958,7 +3928,9 @@ create_int_parameter (const char *name, int value, const char *modname)
sym->attr.use_assoc = 1;
}
/* USE the ISO_FORTRAN_ENV intrinsic module. */
static void
use_iso_fortran_env_module (void)
{
......@@ -4063,6 +4035,7 @@ use_iso_fortran_env_module (void)
}
}
/* Process a USE directive. */
void
......@@ -4073,8 +4046,8 @@ gfc_use_module (void)
int c, line, start;
gfc_symtree *mod_symtree;
filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
+ 1);
filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
+ 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
......@@ -4089,18 +4062,18 @@ gfc_use_module (void)
if (module_fp == NULL && !specified_nonint)
{
if (strcmp (module_name, "iso_fortran_env") == 0
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
"ISO_FORTRAN_ENV intrinsic module at %C") != FAILURE)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
"intrinsic module at %C") != FAILURE)
{
use_iso_fortran_env_module ();
return;
use_iso_fortran_env_module ();
return;
}
module_fp = gfc_open_intrinsic_module (filename);
if (module_fp == NULL && specified_int)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
module_name);
module_name);
}
if (module_fp == NULL)
......@@ -4131,9 +4104,9 @@ gfc_use_module (void)
if (start++ < 2)
parse_name (c);
if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
|| (start == 2 && strcmp (atom_name, " module") != 0))
|| (start == 2 && strcmp (atom_name, " module") != 0))
gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
"file", filename);
"file", filename);
if (c == '\n')
line++;
......@@ -4162,7 +4135,6 @@ gfc_use_module (void)
void
gfc_module_init_2 (void)
{
last_atom = ATOM_LPAREN;
}
......@@ -4170,6 +4142,5 @@ gfc_module_init_2 (void)
void
gfc_module_done_2 (void)
{
free_rename ();
}
gcc/fortran/openmp.c
/* 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. */
......
gcc/fortran/options.c
/* 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;
}
......
gcc/fortran/parse.c
/* 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;
default:
gfc_free_enum_history ();
unexpected_statement (st);
break;
}
}
accept_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++;
/* Free the old (local) symbol. */
old_sym->refs--;
if (old_sym->refs == 0)
gfc_free_symbol (old_sym);
}
&& !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);
}
/* 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;
}
......
gcc/fortran/primary.c
/* 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);
}
......
gcc/fortran/resolve.c
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/fortran/scanner.c
......@@ -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. */
......
gcc/fortran/simplify.c
......@@ -93,20 +93,21 @@ static int xascii_table[256];
node, otherwise returns &gfc_bad_expr and frees the node. */
static gfc_expr *
range_check (gfc_expr * result, const char *name)
range_check (gfc_expr *result, const char *name)
{
switch (gfc_range_check (result))
{
case ARITH_OK:
return result;
case ARITH_OVERFLOW:
gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
gfc_error ("Result of %s overflows its kind at %L", name,
&result->where);
break;
case ARITH_UNDERFLOW:
gfc_error ("Result of %s underflows its kind at %L", name, &result->where);
gfc_error ("Result of %s underflows its kind at %L", name,
&result->where);
break;
case ARITH_NAN:
......@@ -114,7 +115,8 @@ range_check (gfc_expr * result, const char *name)
break;
default:
gfc_error ("Result of %s gives range error for its kind at %L", name, &result->where);
gfc_error ("Result of %s gives range error for its kind at %L", name,
&result->where);
break;
}
......@@ -127,7 +129,7 @@ range_check (gfc_expr * result, const char *name)
kind parameter. Returns the kind, -1 if something went wrong. */
static int
get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
......@@ -190,7 +192,6 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize)
If the bitsize-1 bit is set, this is taken as a sign bit and
the number is converted to the corresponding negative number. */
static void
convert_mpz_to_signed (mpz_t x, int bitsize)
{
......@@ -206,9 +207,9 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
mpz_sub_ui (mask, mask, 1);
/* We negate the number by hand, zeroing the high bits, that is
make it the corresponding positive number, and then have it
negated by GMP, giving the correct representation of the
negative number. */
make it the corresponding positive number, and then have it
negated by GMP, giving the correct representation of the
negative number. */
mpz_com (x, x);
mpz_add_ui (x, x, 1);
mpz_and (x, x, mask);
......@@ -223,7 +224,7 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
/********************** Simplification functions *****************************/
gfc_expr *
gfc_simplify_abs (gfc_expr * e)
gfc_simplify_abs (gfc_expr *e)
{
gfc_expr *result;
......@@ -267,7 +268,7 @@ gfc_simplify_abs (gfc_expr * e)
gfc_expr *
gfc_simplify_achar (gfc_expr * e)
gfc_simplify_achar (gfc_expr *e)
{
gfc_expr *result;
int index;
......@@ -297,14 +298,15 @@ gfc_simplify_achar (gfc_expr * e)
gfc_expr *
gfc_simplify_acos (gfc_expr * x)
gfc_simplify_acos (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
......@@ -319,7 +321,7 @@ gfc_simplify_acos (gfc_expr * x)
}
gfc_expr *
gfc_simplify_acosh (gfc_expr * x)
gfc_simplify_acosh (gfc_expr *x)
{
gfc_expr *result;
......@@ -341,7 +343,7 @@ gfc_simplify_acosh (gfc_expr * x)
}
gfc_expr *
gfc_simplify_adjustl (gfc_expr * e)
gfc_simplify_adjustl (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
......@@ -366,15 +368,10 @@ gfc_simplify_adjustl (gfc_expr * e)
}
for (i = 0; i < len - count; ++i)
{
result->value.character.string[i] =
e->value.character.string[count + i];
}
result->value.character.string[i] = e->value.character.string[count + i];
for (i = len - count; i < len; ++i)
{
result->value.character.string[i] = ' ';
}
result->value.character.string[i] = ' ';
result->value.character.string[len] = '\0'; /* For debugger */
......@@ -383,7 +380,7 @@ gfc_simplify_adjustl (gfc_expr * e)
gfc_expr *
gfc_simplify_adjustr (gfc_expr * e)
gfc_simplify_adjustr (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
......@@ -408,15 +405,10 @@ gfc_simplify_adjustr (gfc_expr * e)
}
for (i = 0; i < count; ++i)
{
result->value.character.string[i] = ' ';
}
result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
{
result->value.character.string[i] =
e->value.character.string[i - count];
}
result->value.character.string[i] = e->value.character.string[i - count];
result->value.character.string[len] = '\0'; /* For debugger */
......@@ -425,9 +417,8 @@ gfc_simplify_adjustr (gfc_expr * e)
gfc_expr *
gfc_simplify_aimag (gfc_expr * e)
gfc_simplify_aimag (gfc_expr *e)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
......@@ -441,7 +432,7 @@ gfc_simplify_aimag (gfc_expr * e)
gfc_expr *
gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rtrunc, *result;
int kind;
......@@ -465,7 +456,7 @@ gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_dint (gfc_expr * e)
gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
......@@ -484,7 +475,7 @@ gfc_simplify_dint (gfc_expr * e)
gfc_expr *
gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
......@@ -505,7 +496,7 @@ gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_and (gfc_expr * x, gfc_expr * y)
gfc_simplify_and (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
......@@ -530,7 +521,7 @@ gfc_simplify_and (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_dnint (gfc_expr * e)
gfc_simplify_dnint (gfc_expr *e)
{
gfc_expr *result;
......@@ -546,14 +537,15 @@ gfc_simplify_dnint (gfc_expr * e)
gfc_expr *
gfc_simplify_asin (gfc_expr * x)
gfc_simplify_asin (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
......@@ -562,14 +554,14 @@ gfc_simplify_asin (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asin(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ASIN");
}
gfc_expr *
gfc_simplify_asinh (gfc_expr * x)
gfc_simplify_asinh (gfc_expr *x)
{
gfc_expr *result;
......@@ -578,14 +570,14 @@ gfc_simplify_asinh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asinh(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ASINH");
}
gfc_expr *
gfc_simplify_atan (gfc_expr * x)
gfc_simplify_atan (gfc_expr *x)
{
gfc_expr *result;
......@@ -594,22 +586,22 @@ gfc_simplify_atan (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atan(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN");
}
gfc_expr *
gfc_simplify_atanh (gfc_expr * x)
gfc_simplify_atanh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_cmp_si (x->value.real, 1) >= 0 ||
mpfr_cmp_si (x->value.real, -1) <= 0)
if (mpfr_cmp_si (x->value.real, 1) >= 0
|| mpfr_cmp_si (x->value.real, -1) <= 0)
{
gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
&x->where);
......@@ -618,14 +610,14 @@ gfc_simplify_atanh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atanh(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATANH");
}
gfc_expr *
gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
{
gfc_expr *result;
......@@ -636,9 +628,8 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
gfc_error
("If first argument of ATAN2 %L is zero, then the second argument "
"must not be zero", &x->where);
gfc_error ("If first argument of ATAN2 %L is zero, then the "
"second argument must not be zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
......@@ -650,7 +641,7 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
gfc_expr *
gfc_simplify_bit_size (gfc_expr * e)
gfc_simplify_bit_size (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -664,7 +655,7 @@ gfc_simplify_bit_size (gfc_expr * e)
gfc_expr *
gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
{
int b;
......@@ -679,7 +670,7 @@ gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
gfc_expr *
gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
gfc_expr *ceil, *result;
int kind;
......@@ -696,7 +687,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real);
gfc_mpfr_to_mpz(result->value.integer, ceil->value.real);
gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
gfc_free_expr (ceil);
......@@ -705,7 +696,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_char (gfc_expr * e, gfc_expr * k)
gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int c, kind;
......@@ -738,7 +729,7 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k)
/* Common subroutine for simplifying CMPLX and DCMPLX. */
static gfc_expr *
simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
......@@ -787,7 +778,7 @@ simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
gfc_expr *
gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
......@@ -804,7 +795,7 @@ gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
gfc_expr *
gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
{
int kind;
......@@ -832,7 +823,7 @@ gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_conjg (gfc_expr * e)
gfc_simplify_conjg (gfc_expr *e)
{
gfc_expr *result;
......@@ -847,7 +838,7 @@ gfc_simplify_conjg (gfc_expr * e)
gfc_expr *
gfc_simplify_cos (gfc_expr * x)
gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
......@@ -869,7 +860,7 @@ gfc_simplify_cos (gfc_expr * x)
mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul(result->value.complex.r, xp, xq, GFC_RND_MODE);
mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
......@@ -889,7 +880,7 @@ gfc_simplify_cos (gfc_expr * x)
gfc_expr *
gfc_simplify_cosh (gfc_expr * x)
gfc_simplify_cosh (gfc_expr *x)
{
gfc_expr *result;
......@@ -905,7 +896,7 @@ gfc_simplify_cosh (gfc_expr * x)
gfc_expr *
gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (x->expr_type != EXPR_CONSTANT
......@@ -917,7 +908,7 @@ gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_dble (gfc_expr * e)
gfc_simplify_dble (gfc_expr *e)
{
gfc_expr *result;
......@@ -947,7 +938,7 @@ gfc_simplify_dble (gfc_expr * e)
gfc_expr *
gfc_simplify_digits (gfc_expr * x)
gfc_simplify_digits (gfc_expr *x)
{
int i, digits;
......@@ -972,7 +963,7 @@ gfc_simplify_digits (gfc_expr * x)
gfc_expr *
gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
......@@ -995,7 +986,8 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
case BT_REAL:
if (mpfr_cmp (x->value.real, y->value.real) > 0)
mpfr_sub (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
mpfr_sub (result->value.real, x->value.real, y->value.real,
GFC_RND_MODE);
else
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
......@@ -1010,15 +1002,14 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
{
gfc_expr *a1, *a2, *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
result =
gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, gfc_default_double_kind);
......@@ -1033,7 +1024,7 @@ gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_epsilon (gfc_expr * e)
gfc_simplify_epsilon (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -1049,7 +1040,7 @@ gfc_simplify_epsilon (gfc_expr * e)
gfc_expr *
gfc_simplify_exp (gfc_expr * x)
gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
......@@ -1062,7 +1053,7 @@ gfc_simplify_exp (gfc_expr * x)
switch (x->ts.type)
{
case BT_REAL:
mpfr_exp(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
......@@ -1085,9 +1076,8 @@ gfc_simplify_exp (gfc_expr * x)
return range_check (result, "EXP");
}
/* FIXME: MPFR should be able to do this better */
gfc_expr *
gfc_simplify_exponent (gfc_expr * x)
gfc_simplify_exponent (gfc_expr *x)
{
int i;
gfc_expr *result;
......@@ -1114,7 +1104,7 @@ gfc_simplify_exponent (gfc_expr * x)
gfc_expr *
gfc_simplify_float (gfc_expr * a)
gfc_simplify_float (gfc_expr *a)
{
gfc_expr *result;
......@@ -1127,7 +1117,7 @@ gfc_simplify_float (gfc_expr * a)
gfc_expr *
gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
mpfr_t floor;
......@@ -1155,7 +1145,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_fraction (gfc_expr * x)
gfc_simplify_fraction (gfc_expr *x)
{
gfc_expr *result;
mpfr_t absv, exp, pow2;
......@@ -1196,7 +1186,7 @@ gfc_simplify_fraction (gfc_expr * x)
gfc_expr *
gfc_simplify_huge (gfc_expr * e)
gfc_simplify_huge (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -1224,7 +1214,7 @@ gfc_simplify_huge (gfc_expr * e)
gfc_expr *
gfc_simplify_iachar (gfc_expr * e)
gfc_simplify_iachar (gfc_expr *e)
{
gfc_expr *result;
int index;
......@@ -1248,7 +1238,7 @@ gfc_simplify_iachar (gfc_expr * e)
gfc_expr *
gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
......@@ -1264,7 +1254,7 @@ gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
......@@ -1302,7 +1292,7 @@ gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
{
gfc_expr *result;
int pos, len;
......@@ -1350,17 +1340,11 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
for (i = 0; i < bitsize; i++)
{
if (bits[i] == 0)
{
mpz_clrbit (result->value.integer, i);
}
mpz_clrbit (result->value.integer, i);
else if (bits[i] == 1)
{
mpz_setbit (result->value.integer, i);
}
mpz_setbit (result->value.integer, i);
else
{
gfc_internal_error ("IBITS: Bad bit");
}
gfc_internal_error ("IBITS: Bad bit");
}
gfc_free (bits);
......@@ -1370,7 +1354,7 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
gfc_expr *
gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
......@@ -1408,7 +1392,7 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_ichar (gfc_expr * e)
gfc_simplify_ichar (gfc_expr *e)
{
gfc_expr *result;
int index;
......@@ -1438,7 +1422,7 @@ gfc_simplify_ichar (gfc_expr * e)
gfc_expr *
gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
......@@ -1454,7 +1438,7 @@ gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
{
gfc_expr *result;
int back, len, lensub;
......@@ -1482,7 +1466,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
if (back == 0)
{
if (lensub == 0)
{
mpz_set_si (result->value.integer, 1);
......@@ -1494,8 +1477,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{
for (j = 0; j < lensub; j++)
{
if (y->value.character.string[j] ==
x->value.character.string[i])
if (y->value.character.string[j]
== x->value.character.string[i])
{
index = i + 1;
goto done;
......@@ -1509,16 +1492,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{
for (j = 0; j < lensub; j++)
{
if (y->value.character.string[j] ==
x->value.character.string[i])
if (y->value.character.string[j]
== x->value.character.string[i])
{
start = i;
count = 0;
for (k = 0; k < lensub; k++)
{
if (y->value.character.string[k] ==
x->value.character.string[k + start])
if (y->value.character.string[k]
== x->value.character.string[k + start])
count++;
}
......@@ -1535,7 +1518,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
}
else
{
if (lensub == 0)
{
mpz_set_si (result->value.integer, len + 1);
......@@ -1547,8 +1529,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{
for (j = 0; j < lensub; j++)
{
if (y->value.character.string[j] ==
x->value.character.string[len - i])
if (y->value.character.string[j]
== x->value.character.string[len - i])
{
index = len - i + 1;
goto done;
......@@ -1562,16 +1544,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{
for (j = 0; j < lensub; j++)
{
if (y->value.character.string[j] ==
x->value.character.string[len - i])
if (y->value.character.string[j]
== x->value.character.string[len - i])
{
start = len - i;
if (start <= len - lensub)
{
count = 0;
for (k = 0; k < lensub; k++)
if (y->value.character.string[k] ==
x->value.character.string[k + start])
if (y->value.character.string[k]
== x->value.character.string[k + start])
count++;
if (count == lensub)
......@@ -1597,7 +1579,7 @@ done:
gfc_expr *
gfc_simplify_int (gfc_expr * e, gfc_expr * k)
gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rpart, *rtrunc, *result;
int kind;
......@@ -1644,7 +1626,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k)
static gfc_expr *
gfc_simplify_intconv (gfc_expr * e, int kind, const char *name)
gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
{
gfc_expr *rpart, *rtrunc, *result;
......@@ -1684,27 +1666,30 @@ gfc_simplify_intconv (gfc_expr * e, int kind, const char *name)
return range_check (result, name);
}
gfc_expr *
gfc_simplify_int2 (gfc_expr * e)
gfc_simplify_int2 (gfc_expr *e)
{
return gfc_simplify_intconv (e, 2, "INT2");
}
gfc_expr *
gfc_simplify_int8 (gfc_expr * e)
gfc_simplify_int8 (gfc_expr *e)
{
return gfc_simplify_intconv (e, 8, "INT8");
}
gfc_expr *
gfc_simplify_long (gfc_expr * e)
gfc_simplify_long (gfc_expr *e)
{
return gfc_simplify_intconv (e, 4, "LONG");
}
gfc_expr *
gfc_simplify_ifix (gfc_expr * e)
gfc_simplify_ifix (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
......@@ -1725,7 +1710,7 @@ gfc_simplify_ifix (gfc_expr * e)
gfc_expr *
gfc_simplify_idint (gfc_expr * e)
gfc_simplify_idint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
......@@ -1746,7 +1731,7 @@ gfc_simplify_idint (gfc_expr * e)
gfc_expr *
gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
......@@ -1761,7 +1746,7 @@ gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{
gfc_expr *result;
int shift, ashift, isize, k, *bits, i;
......@@ -1786,9 +1771,8 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
if (ashift > isize)
{
gfc_error
("Magnitude of second argument of ISHFT exceeds bit size at %L",
&s->where);
gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
"at %L", &s->where);
return &gfc_bad_expr;
}
......@@ -1840,7 +1824,7 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
gfc_expr *
gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
{
gfc_expr *result;
int shift, ashift, isize, ssize, delta, k;
......@@ -1861,7 +1845,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
if (sz != NULL)
{
if (sz->expr_type != EXPR_CONSTANT)
return NULL;
return NULL;
if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
{
......@@ -1956,7 +1940,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
gfc_expr *
gfc_simplify_kind (gfc_expr * e)
gfc_simplify_kind (gfc_expr *e)
{
if (e->ts.type == BT_DERIVED)
......@@ -1970,7 +1954,7 @@ gfc_simplify_kind (gfc_expr * e)
static gfc_expr *
simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
......@@ -2077,14 +2061,14 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
gfc_expr *
gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim)
{
return simplify_bound (array, dim, 0);
}
gfc_expr *
gfc_simplify_len (gfc_expr * e)
gfc_simplify_len (gfc_expr *e)
{
gfc_expr *result;
......@@ -2110,7 +2094,7 @@ gfc_simplify_len (gfc_expr * e)
gfc_expr *
gfc_simplify_len_trim (gfc_expr * e)
gfc_simplify_len_trim (gfc_expr *e)
{
gfc_expr *result;
int count, len, lentrim, i;
......@@ -2137,9 +2121,8 @@ gfc_simplify_len_trim (gfc_expr * e)
gfc_expr *
gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
......@@ -2149,9 +2132,8 @@ gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
gfc_expr *
gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
......@@ -2161,9 +2143,8 @@ gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
gfc_expr *
gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
......@@ -2173,9 +2154,8 @@ gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
gfc_expr *
gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
......@@ -2185,7 +2165,7 @@ gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
gfc_expr *
gfc_simplify_log (gfc_expr * x)
gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xr, xi;
......@@ -2202,14 +2182,13 @@ gfc_simplify_log (gfc_expr * x)
case BT_REAL:
if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error
("Argument of LOG at %L cannot be less than or equal to zero",
&x->where);
gfc_error ("Argument of LOG at %L cannot be less than or equal "
"to zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
......@@ -2225,8 +2204,8 @@ gfc_simplify_log (gfc_expr * x)
mpfr_init (xr);
mpfr_init (xi);
mpfr_atan2 (result->value.complex.i, x->value.complex.i, x->value.complex.r,
GFC_RND_MODE);
mpfr_atan2 (result->value.complex.i, x->value.complex.i,
x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
......@@ -2248,7 +2227,7 @@ gfc_simplify_log (gfc_expr * x)
gfc_expr *
gfc_simplify_log10 (gfc_expr * x)
gfc_simplify_log10 (gfc_expr *x)
{
gfc_expr *result;
......@@ -2259,9 +2238,8 @@ gfc_simplify_log10 (gfc_expr * x)
if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error
("Argument of LOG10 at %L cannot be less than or equal to zero",
&x->where);
gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
"to zero", &x->where);
return &gfc_bad_expr;
}
......@@ -2274,7 +2252,7 @@ gfc_simplify_log10 (gfc_expr * x)
gfc_expr *
gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
......@@ -2302,7 +2280,7 @@ gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
MAX(), -1 for MIN(). */
static gfc_expr *
simplify_min_max (gfc_expr * expr, int sign)
simplify_min_max (gfc_expr *expr, int sign)
{
gfc_actual_arglist *arg, *last, *extremum;
gfc_intrinsic_sym * specific;
......@@ -2334,10 +2312,10 @@ simplify_min_max (gfc_expr * expr, int sign)
break;
case BT_REAL:
if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) *
sign > 0)
if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
* sign > 0)
mpfr_set (extremum->expr->value.real, arg->expr->value.real,
GFC_RND_MODE);
GFC_RND_MODE);
break;
......@@ -2375,21 +2353,21 @@ simplify_min_max (gfc_expr * expr, int sign)
gfc_expr *
gfc_simplify_min (gfc_expr * e)
gfc_simplify_min (gfc_expr *e)
{
return simplify_min_max (e, -1);
}
gfc_expr *
gfc_simplify_max (gfc_expr * e)
gfc_simplify_max (gfc_expr *e)
{
return simplify_min_max (e, 1);
}
gfc_expr *
gfc_simplify_maxexponent (gfc_expr * x)
gfc_simplify_maxexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
......@@ -2404,7 +2382,7 @@ gfc_simplify_maxexponent (gfc_expr * x)
gfc_expr *
gfc_simplify_minexponent (gfc_expr * x)
gfc_simplify_minexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
......@@ -2419,7 +2397,7 @@ gfc_simplify_minexponent (gfc_expr * x)
gfc_expr *
gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
mpfr_t quot, iquot, term;
......@@ -2477,7 +2455,7 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
gfc_expr *
gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
mpfr_t quot, iquot, term;
......@@ -2495,7 +2473,7 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
/* Result is processor-dependent. This processor just opts
to not handle it at all. */
to not handle it at all. */
gfc_error ("Second argument of MODULO at %L is zero", &a->where);
gfc_free_expr (result);
return &gfc_bad_expr;
......@@ -2538,18 +2516,18 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
/* Exists for the sole purpose of consistency with other intrinsics. */
gfc_expr *
gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED,
gfc_expr * fp ATTRIBUTE_UNUSED,
gfc_expr * l ATTRIBUTE_UNUSED,
gfc_expr * to ATTRIBUTE_UNUSED,
gfc_expr * tp ATTRIBUTE_UNUSED)
gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
gfc_expr *fp ATTRIBUTE_UNUSED,
gfc_expr *l ATTRIBUTE_UNUSED,
gfc_expr *to ATTRIBUTE_UNUSED,
gfc_expr *tp ATTRIBUTE_UNUSED)
{
return NULL;
}
gfc_expr *
gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
{
gfc_expr *result;
mpfr_t tmp;
......@@ -2560,7 +2538,8 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
if (mpfr_sgn (s->value.real) == 0)
{
gfc_error ("Second argument of NEAREST at %L shall not be zero", &s->where);
gfc_error ("Second argument of NEAREST at %L shall not be zero",
&s->where);
return &gfc_bad_expr;
}
......@@ -2571,14 +2550,14 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
mpfr_init (tmp);
mpfr_set_inf (tmp, sgn);
mpfr_nexttoward (result->value.real, tmp);
mpfr_clear(tmp);
mpfr_clear (tmp);
return range_check (result, "NEAREST");
}
static gfc_expr *
simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
{
gfc_expr *itrunc, *result;
int kind;
......@@ -2594,7 +2573,7 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
itrunc = gfc_copy_expr (e);
mpfr_round(itrunc->value.real, e->value.real);
mpfr_round (itrunc->value.real, e->value.real);
gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
......@@ -2605,7 +2584,7 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_new_line (gfc_expr * e)
gfc_simplify_new_line (gfc_expr *e)
{
gfc_expr *result;
......@@ -2624,21 +2603,21 @@ gfc_simplify_new_line (gfc_expr * e)
gfc_expr *
gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
{
return simplify_nint ("NINT", e, k);
}
gfc_expr *
gfc_simplify_idnint (gfc_expr * e)
gfc_simplify_idnint (gfc_expr *e)
{
return simplify_nint ("IDNINT", e, NULL);
}
gfc_expr *
gfc_simplify_not (gfc_expr * e)
gfc_simplify_not (gfc_expr *e)
{
gfc_expr *result;
......@@ -2654,7 +2633,7 @@ gfc_simplify_not (gfc_expr * e)
gfc_expr *
gfc_simplify_null (gfc_expr * mold)
gfc_simplify_null (gfc_expr *mold)
{
gfc_expr *result;
......@@ -2672,7 +2651,7 @@ gfc_simplify_null (gfc_expr * mold)
gfc_expr *
gfc_simplify_or (gfc_expr * x, gfc_expr * y)
gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
......@@ -2697,7 +2676,7 @@ gfc_simplify_or (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_precision (gfc_expr * e)
gfc_simplify_precision (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -2712,7 +2691,7 @@ gfc_simplify_precision (gfc_expr * e)
gfc_expr *
gfc_simplify_radix (gfc_expr * e)
gfc_simplify_radix (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -2740,7 +2719,7 @@ gfc_simplify_radix (gfc_expr * e)
gfc_expr *
gfc_simplify_range (gfc_expr * e)
gfc_simplify_range (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -2771,7 +2750,7 @@ gfc_simplify_range (gfc_expr * e)
gfc_expr *
gfc_simplify_real (gfc_expr * e, gfc_expr * k)
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
......@@ -2811,7 +2790,7 @@ gfc_simplify_real (gfc_expr * e, gfc_expr * k)
gfc_expr *
gfc_simplify_realpart (gfc_expr * e)
gfc_simplify_realpart (gfc_expr *e)
{
gfc_expr *result;
......@@ -2825,7 +2804,7 @@ gfc_simplify_realpart (gfc_expr * e)
}
gfc_expr *
gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
{
gfc_expr *result;
int i, j, len, ncopies, nlen;
......@@ -2857,8 +2836,8 @@ gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
for (i = 0; i < ncopies; i++)
for (j = 0; j < len; j++)
result->value.character.string[j + i * len] =
e->value.character.string[j];
result->value.character.string[j + i * len]
= e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
......@@ -2868,10 +2847,9 @@ gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
/* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr *
gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
gfc_expr * pad, gfc_expr * order_exp)
gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
gfc_expr *pad, gfc_expr *order_exp)
{
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
gfc_constructor *head, *tail;
......@@ -2888,8 +2866,7 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
return NULL;
if (pad != NULL
&& (pad->expr_type != EXPR_ARRAY
|| !gfc_is_constant_expr (pad)))
&& (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
return NULL;
if (order_exp != NULL
......@@ -2947,11 +2924,9 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
{
for (i = 0; i < rank; i++)
order[i] = i;
}
else
{
for (i = 0; i < rank; i++)
x[i] = 0;
......@@ -2960,9 +2935,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
e = gfc_get_array_element (order_exp, i);
if (e == NULL)
{
gfc_error
("ORDER parameter of RESHAPE at %L is not the same size "
"as SHAPE parameter", &order_exp->where);
gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
"size as SHAPE parameter", &order_exp->where);
goto bad_reshape;
}
......@@ -3043,9 +3017,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
if (npad == 0)
{
gfc_error
("PAD parameter required for short SOURCE parameter at %L",
&source->where);
gfc_error ("PAD parameter required for short SOURCE parameter "
"at %L", &source->where);
goto bad_reshape;
}
......@@ -3104,7 +3077,7 @@ bad_reshape:
gfc_expr *
gfc_simplify_rrspacing (gfc_expr * x)
gfc_simplify_rrspacing (gfc_expr *x)
{
gfc_expr *result;
int i;
......@@ -3119,7 +3092,7 @@ gfc_simplify_rrspacing (gfc_expr * x)
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
/* Special case x = 0 and 0. */
/* Special case x = -0 and 0. */
if (mpfr_sgn (result->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
......@@ -3138,7 +3111,7 @@ gfc_simplify_rrspacing (gfc_expr * x)
gfc_expr *
gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
{
int k, neg_flag, power, exp_range;
mpfr_t scale, radix;
......@@ -3197,7 +3170,7 @@ gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
gfc_expr *
gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
{
gfc_expr *result;
int back;
......@@ -3225,27 +3198,27 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
else
{
if (back == 0)
{
indx =
strcspn (e->value.character.string, c->value.character.string) + 1;
if (indx > len)
indx = 0;
}
{
indx = strcspn (e->value.character.string, c->value.character.string)
+ 1;
if (indx > len)
indx = 0;
}
else
{
i = 0;
for (indx = len; indx > 0; indx--)
{
for (i = 0; i < lenc; i++)
{
if (c->value.character.string[i]
== e->value.character.string[indx - 1])
break;
}
if (i < lenc)
break;
}
}
{
i = 0;
for (indx = len; indx > 0; indx--)
{
for (i = 0; i < lenc; i++)
{
if (c->value.character.string[i]
== e->value.character.string[indx - 1])
break;
}
if (i < lenc)
break;
}
}
}
mpz_set_ui (result->value.integer, indx);
return range_check (result, "SCAN");
......@@ -3253,7 +3226,7 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
gfc_expr *
gfc_simplify_selected_int_kind (gfc_expr * e)
gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
gfc_expr *result;
......@@ -3279,7 +3252,7 @@ gfc_simplify_selected_int_kind (gfc_expr * e)
gfc_expr *
gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
{
int range, precision, i, kind, found_precision, found_range;
gfc_expr *result;
......@@ -3337,7 +3310,7 @@ gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
gfc_expr *
gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
mpfr_t exp, absv, log2, pow2, frac;
......@@ -3387,7 +3360,7 @@ gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
gfc_expr *
gfc_simplify_shape (gfc_expr * source)
gfc_simplify_shape (gfc_expr *source)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f;
......@@ -3440,7 +3413,7 @@ gfc_simplify_shape (gfc_expr * source)
gfc_expr *
gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
{
mpz_t size;
gfc_expr *result;
......@@ -3471,7 +3444,7 @@ gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
gfc_expr *
gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
......@@ -3491,7 +3464,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
case BT_REAL:
/* TODO: Handle -0.0 and +0.0 correctly on machines that support
it. */
it. */
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
if (mpfr_sgn (y->value.real) < 0)
mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
......@@ -3507,7 +3480,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
gfc_expr *
gfc_simplify_sin (gfc_expr * x)
gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
......@@ -3549,7 +3522,7 @@ gfc_simplify_sin (gfc_expr * x)
gfc_expr *
gfc_simplify_sinh (gfc_expr * x)
gfc_simplify_sinh (gfc_expr *x)
{
gfc_expr *result;
......@@ -3558,7 +3531,7 @@ gfc_simplify_sinh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "SINH");
}
......@@ -3568,7 +3541,7 @@ gfc_simplify_sinh (gfc_expr * x)
single precision. TODO: Rounding! */
gfc_expr *
gfc_simplify_sngl (gfc_expr * a)
gfc_simplify_sngl (gfc_expr *a)
{
gfc_expr *result;
......@@ -3581,7 +3554,7 @@ gfc_simplify_sngl (gfc_expr * a)
gfc_expr *
gfc_simplify_spacing (gfc_expr * x)
gfc_simplify_spacing (gfc_expr *x)
{
gfc_expr *result;
int i;
......@@ -3619,7 +3592,7 @@ gfc_simplify_spacing (gfc_expr * x)
gfc_expr *
gfc_simplify_sqrt (gfc_expr * e)
gfc_simplify_sqrt (gfc_expr *e)
{
gfc_expr *result;
mpfr_t ac, ad, s, t, w;
......@@ -3640,7 +3613,7 @@ gfc_simplify_sqrt (gfc_expr * e)
case BT_COMPLEX:
/* Formula taken from Numerical Recipes to avoid over- and
underflow. */
underflow. */
gfc_set_model (e->value.real);
mpfr_init (ac);
......@@ -3652,7 +3625,6 @@ gfc_simplify_sqrt (gfc_expr * e)
if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
&& mpfr_cmp_ui (e->value.complex.i, 0) == 0)
{
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
......@@ -3736,7 +3708,7 @@ negative_arg:
gfc_expr *
gfc_simplify_tan (gfc_expr * x)
gfc_simplify_tan (gfc_expr *x)
{
int i;
gfc_expr *result;
......@@ -3755,7 +3727,7 @@ gfc_simplify_tan (gfc_expr * x)
gfc_expr *
gfc_simplify_tanh (gfc_expr * x)
gfc_simplify_tanh (gfc_expr *x)
{
gfc_expr *result;
......@@ -3772,7 +3744,7 @@ gfc_simplify_tanh (gfc_expr * x)
gfc_expr *
gfc_simplify_tiny (gfc_expr * e)
gfc_simplify_tiny (gfc_expr *e)
{
gfc_expr *result;
int i;
......@@ -3787,9 +3759,8 @@ gfc_simplify_tiny (gfc_expr * e)
gfc_expr *
gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
/* Reference mold and size to suppress warning. */
if (gfc_init_expr && (mold || size))
gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
......@@ -3800,7 +3771,7 @@ gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
gfc_expr *
gfc_simplify_trim (gfc_expr * e)
gfc_simplify_trim (gfc_expr *e)
{
gfc_expr *result;
int count, i, len, lentrim;
......@@ -3835,14 +3806,14 @@ gfc_simplify_trim (gfc_expr * e)
gfc_expr *
gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
{
return simplify_bound (array, dim, 1);
}
gfc_expr *
gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
{
gfc_expr *result;
int back;
......@@ -3877,8 +3848,8 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
return result;
}
index =
strspn (s->value.character.string, set->value.character.string) + 1;
index = strspn (s->value.character.string, set->value.character.string)
+ 1;
if (index > len)
index = 0;
......@@ -3891,16 +3862,16 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
return result;
}
for (index = len; index > 0; index --)
{
for (i = 0; i < lenset; i++)
{
if (s->value.character.string[index - 1]
== set->value.character.string[i])
break;
}
if (i == lenset)
break;
}
{
for (i = 0; i < lenset; i++)
{
if (s->value.character.string[index - 1]
== set->value.character.string[i])
break;
}
if (i == lenset)
break;
}
}
mpz_set_ui (result->value.integer, index);
......@@ -3909,7 +3880,7 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
gfc_expr *
gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
......@@ -3926,15 +3897,14 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
else /* BT_LOGICAL */
{
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
result->value.logical = (x->value.logical && ! y->value.logical)
|| (! x->value.logical && y->value.logical);
result->value.logical = (x->value.logical && !y->value.logical)
|| (!x->value.logical && y->value.logical);
}
return range_check (result, "XOR");
}
/****************** Constant simplification *****************/
/* Master function to convert one constant to another. While this is
......@@ -3943,7 +3913,7 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
do_simplify(). */
gfc_expr *
gfc_convert_constant (gfc_expr * e, bt type, int kind)
gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
gfc_constructor *head, *c, *tail = NULL;
......@@ -4135,6 +4105,5 @@ invert_table (const int *table, int *xtable)
void
gfc_simplify_init_1 (void)
{
invert_table (ascii_table, xascii_table);
}
gcc/fortran/st.c
/* 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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment