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> 2007-01-20 Roger Sayle <roger@eyesopen.com>
* module.c (mio_array_ref): The dimen_type fields of an array ref * module.c (mio_array_ref): The dimen_type fields of an array ref
......
gcc/fortran/matchexp.c
/* Expression parser. /* Expression parser.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software Foundation, Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
This file is part of GCC. This file is part of GCC.
...@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "gfortran.h" #include "gfortran.h"
...@@ -91,7 +90,7 @@ error: ...@@ -91,7 +90,7 @@ error:
operator already. */ operator already. */
static match static match
match_defined_operator (gfc_user_op ** result) match_defined_operator (gfc_user_op **result)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
match m; match m;
...@@ -126,6 +125,7 @@ next_operator (gfc_intrinsic_op t) ...@@ -126,6 +125,7 @@ next_operator (gfc_intrinsic_op t)
/* Call the INTRINSIC_PARENTHESES function. This is both /* Call the INTRINSIC_PARENTHESES function. This is both
used explicitly, as below, or by resolve.c to generate used explicitly, as below, or by resolve.c to generate
temporaries. */ temporaries. */
gfc_expr * gfc_expr *
gfc_get_parentheses (gfc_expr *e) gfc_get_parentheses (gfc_expr *e)
{ {
...@@ -146,7 +146,7 @@ gfc_get_parentheses (gfc_expr *e) ...@@ -146,7 +146,7 @@ gfc_get_parentheses (gfc_expr *e)
/* Match a primary expression. */ /* Match a primary expression. */
static match static match
match_primary (gfc_expr ** result) match_primary (gfc_expr **result)
{ {
match m; match m;
gfc_expr *e; gfc_expr *e;
...@@ -206,8 +206,8 @@ syntax: ...@@ -206,8 +206,8 @@ syntax:
/* Build an operator expression node. */ /* Build an operator expression node. */
static gfc_expr * static gfc_expr *
build_node (gfc_intrinsic_op operator, locus * where, build_node (gfc_intrinsic_op operator, locus *where,
gfc_expr * op1, gfc_expr * op2) gfc_expr *op1, gfc_expr *op2)
{ {
gfc_expr *new; gfc_expr *new;
...@@ -226,7 +226,7 @@ build_node (gfc_intrinsic_op operator, locus * where, ...@@ -226,7 +226,7 @@ build_node (gfc_intrinsic_op operator, locus * where,
/* Match a level 1 expression. */ /* Match a level 1 expression. */
static match static match
match_level_1 (gfc_expr ** result) match_level_1 (gfc_expr **result)
{ {
gfc_user_op *uop; gfc_user_op *uop;
gfc_expr *e, *f; gfc_expr *e, *f;
...@@ -272,14 +272,12 @@ match_level_1 (gfc_expr ** result) ...@@ -272,14 +272,12 @@ match_level_1 (gfc_expr ** result)
or add-operand or add-operand
*/ */
static match match_ext_mult_operand (gfc_expr ** result); static match match_ext_mult_operand (gfc_expr **result);
static match match_ext_add_operand (gfc_expr ** result); static match match_ext_add_operand (gfc_expr **result);
static int static int
match_add_op (void) match_add_op (void)
{ {
if (next_operator (INTRINSIC_MINUS)) if (next_operator (INTRINSIC_MINUS))
return -1; return -1;
if (next_operator (INTRINSIC_PLUS)) if (next_operator (INTRINSIC_PLUS))
...@@ -289,7 +287,7 @@ match_add_op (void) ...@@ -289,7 +287,7 @@ match_add_op (void)
static match static match
match_mult_operand (gfc_expr ** result) match_mult_operand (gfc_expr **result)
{ {
gfc_expr *e, *exp, *r; gfc_expr *e, *exp, *r;
locus where; locus where;
...@@ -332,7 +330,7 @@ match_mult_operand (gfc_expr ** result) ...@@ -332,7 +330,7 @@ match_mult_operand (gfc_expr ** result)
static match static match
match_ext_mult_operand (gfc_expr ** result) match_ext_mult_operand (gfc_expr **result)
{ {
gfc_expr *all, *e; gfc_expr *all, *e;
locus where; locus where;
...@@ -345,8 +343,8 @@ match_ext_mult_operand (gfc_expr ** result) ...@@ -345,8 +343,8 @@ match_ext_mult_operand (gfc_expr ** result)
if (i == 0) if (i == 0)
return match_mult_operand (result); return match_mult_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following" if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
" arithmetic operator (use parentheses) at %C") "arithmetic operator (use parentheses) at %C")
== FAILURE) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -372,7 +370,7 @@ match_ext_mult_operand (gfc_expr ** result) ...@@ -372,7 +370,7 @@ match_ext_mult_operand (gfc_expr ** result)
static match static match
match_add_operand (gfc_expr ** result) match_add_operand (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where, old_loc; locus where, old_loc;
...@@ -436,7 +434,7 @@ match_add_operand (gfc_expr ** result) ...@@ -436,7 +434,7 @@ match_add_operand (gfc_expr ** result)
static match static match
match_ext_add_operand (gfc_expr ** result) match_ext_add_operand (gfc_expr **result)
{ {
gfc_expr *all, *e; gfc_expr *all, *e;
locus where; locus where;
...@@ -449,8 +447,8 @@ match_ext_add_operand (gfc_expr ** result) ...@@ -449,8 +447,8 @@ match_ext_add_operand (gfc_expr ** result)
if (i == 0) if (i == 0)
return match_add_operand (result); return match_add_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following" if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
" arithmetic operator (use parentheses) at %C") "arithmetic operator (use parentheses) at %C")
== FAILURE) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -478,7 +476,7 @@ match_ext_add_operand (gfc_expr ** result) ...@@ -478,7 +476,7 @@ match_ext_add_operand (gfc_expr ** result)
/* Match a level 2 expression. */ /* Match a level 2 expression. */
static match static match
match_level_2 (gfc_expr ** result) match_level_2 (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where; locus where;
...@@ -521,7 +519,7 @@ match_level_2 (gfc_expr ** result) ...@@ -521,7 +519,7 @@ match_level_2 (gfc_expr ** result)
all->where = where; all->where = where;
/* Append add-operands to the sum */ /* Append add-operands to the sum. */
for (;;) for (;;)
{ {
...@@ -563,7 +561,7 @@ match_level_2 (gfc_expr ** result) ...@@ -563,7 +561,7 @@ match_level_2 (gfc_expr ** result)
/* Match a level three expression. */ /* Match a level three expression. */
static match static match
match_level_3 (gfc_expr ** result) match_level_3 (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where; locus where;
...@@ -609,7 +607,7 @@ match_level_3 (gfc_expr ** result) ...@@ -609,7 +607,7 @@ match_level_3 (gfc_expr ** result)
/* Match a level 4 expression. */ /* Match a level 4 expression. */
static match static match
match_level_4 (gfc_expr ** result) match_level_4 (gfc_expr **result)
{ {
gfc_expr *left, *right, *r; gfc_expr *left, *right, *r;
gfc_intrinsic_op i; gfc_intrinsic_op i;
...@@ -693,7 +691,7 @@ match_level_4 (gfc_expr ** result) ...@@ -693,7 +691,7 @@ match_level_4 (gfc_expr ** result)
static match static match
match_and_operand (gfc_expr ** result) match_and_operand (gfc_expr **result)
{ {
gfc_expr *e, *r; gfc_expr *e, *r;
locus where; locus where;
...@@ -726,7 +724,7 @@ match_and_operand (gfc_expr ** result) ...@@ -726,7 +724,7 @@ match_and_operand (gfc_expr ** result)
static match static match
match_or_operand (gfc_expr ** result) match_or_operand (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where; locus where;
...@@ -769,7 +767,7 @@ match_or_operand (gfc_expr ** result) ...@@ -769,7 +767,7 @@ match_or_operand (gfc_expr ** result)
static match static match
match_equiv_operand (gfc_expr ** result) match_equiv_operand (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where; locus where;
...@@ -814,7 +812,7 @@ match_equiv_operand (gfc_expr ** result) ...@@ -814,7 +812,7 @@ match_equiv_operand (gfc_expr ** result)
/* Match a level 5 expression. */ /* Match a level 5 expression. */
static match static match
match_level_5 (gfc_expr ** result) match_level_5 (gfc_expr **result)
{ {
gfc_expr *all, *e, *total; gfc_expr *all, *e, *total;
locus where; locus where;
...@@ -873,7 +871,7 @@ match_level_5 (gfc_expr ** result) ...@@ -873,7 +871,7 @@ match_level_5 (gfc_expr ** result)
level 5 expressions separated by binary operators. */ level 5 expressions separated by binary operators. */
match match
gfc_match_expr (gfc_expr ** result) gfc_match_expr (gfc_expr **result)
{ {
gfc_expr *all, *e; gfc_expr *all, *e;
gfc_user_op *uop; gfc_user_op *uop;
......
gcc/fortran/misc.c
/* Miscellaneous stuff that doesn't fit anywhere else. /* Miscellaneous stuff that doesn't fit anywhere else.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
This file is part of GCC. This file is part of GCC.
...@@ -20,12 +20,10 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "gfortran.h" #include "gfortran.h"
/* Get a block of memory. Many callers assume that the memory we /* Get a block of memory. Many callers assume that the memory we
return is zeroed. */ return is zeroed. */
...@@ -54,7 +52,6 @@ gfc_getmem (size_t n) ...@@ -54,7 +52,6 @@ gfc_getmem (size_t n)
void void
gfc_free (void *p) gfc_free (void *p)
{ {
if (p != NULL) if (p != NULL)
free (p); free (p);
} }
...@@ -63,10 +60,10 @@ gfc_free (void *p) ...@@ -63,10 +60,10 @@ gfc_free (void *p)
#undef temp #undef temp
/* Get terminal width */ /* Get terminal width. */
int int
gfc_terminal_width(void) gfc_terminal_width (void)
{ {
return 80; return 80;
} }
...@@ -75,9 +72,8 @@ gfc_terminal_width(void) ...@@ -75,9 +72,8 @@ gfc_terminal_width(void)
/* Initialize a typespec to unknown. */ /* Initialize a typespec to unknown. */
void void
gfc_clear_ts (gfc_typespec * ts) gfc_clear_ts (gfc_typespec *ts)
{ {
ts->type = BT_UNKNOWN; ts->type = BT_UNKNOWN;
ts->kind = 0; ts->kind = 0;
ts->derived = NULL; ts->derived = NULL;
...@@ -154,9 +150,9 @@ gfc_basic_typename (bt type) ...@@ -154,9 +150,9 @@ gfc_basic_typename (bt type)
the argument list of a single statement. */ the argument list of a single statement. */
const char * 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; static int flag = 0;
char *buffer; char *buffer;
...@@ -204,9 +200,8 @@ gfc_typename (gfc_typespec * ts) ...@@ -204,9 +200,8 @@ gfc_typename (gfc_typespec * ts)
returning a pointer to the string. */ returning a pointer to the string. */
const char * const char *
gfc_code2string (const mstring * m, int code) gfc_code2string (const mstring *m, int code)
{ {
while (m->string != NULL) while (m->string != NULL)
{ {
if (m->tag == code) if (m->tag == code)
...@@ -220,13 +215,11 @@ gfc_code2string (const mstring * m, int 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 /* 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 field. Returns the final tag if no matches to the string are found. */
found. */
int int
gfc_string2code (const mstring * m, const char *string) gfc_string2code (const mstring *m, const char *string)
{ {
for (; m->string != NULL; m++) for (; m->string != NULL; m++)
if (strcmp (m->string, string) == 0) if (strcmp (m->string, string) == 0)
return m->tag; return m->tag;
...@@ -237,10 +230,10 @@ gfc_string2code (const mstring * m, const char *string) ...@@ -237,10 +230,10 @@ gfc_string2code (const mstring * m, const char *string)
/* Convert an intent code to a string. */ /* Convert an intent code to a string. */
/* TODO: move to gfortran.h as define. */ /* TODO: move to gfortran.h as define. */
const char * const char *
gfc_intent_string (sym_intent i) gfc_intent_string (sym_intent i)
{ {
return gfc_code2string (intents, i); return gfc_code2string (intents, i);
} }
...@@ -265,7 +258,6 @@ gfc_init_1 (void) ...@@ -265,7 +258,6 @@ gfc_init_1 (void)
void void
gfc_init_2 (void) gfc_init_2 (void)
{ {
gfc_symbol_init_2 (); gfc_symbol_init_2 ();
gfc_module_init_2 (); gfc_module_init_2 ();
} }
...@@ -289,7 +281,6 @@ gfc_done_1 (void) ...@@ -289,7 +281,6 @@ gfc_done_1 (void)
void void
gfc_done_2 (void) gfc_done_2 (void)
{ {
gfc_symbol_done_2 (); gfc_symbol_done_2 ();
gfc_module_done_2 (); gfc_module_done_2 ();
} }
......
gcc/fortran/module.c
/* Handle modules, which amounts to loading and saving symbols and /* Handle modules, which amounts to loading and saving symbols and
their attendant structures. their attendant structures.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
This file is part of GCC. This file is part of GCC.
...@@ -199,7 +199,7 @@ static bool in_load_equiv; ...@@ -199,7 +199,7 @@ static bool in_load_equiv;
/* Recursively free the tree of pointer structures. */ /* Recursively free the tree of pointer structures. */
static void static void
free_pi_tree (pointer_info * p) free_pi_tree (pointer_info *p)
{ {
if (p == NULL) if (p == NULL)
return; return;
...@@ -218,7 +218,7 @@ free_pi_tree (pointer_info * p) ...@@ -218,7 +218,7 @@ free_pi_tree (pointer_info * p)
module. */ module. */
static int static int
compare_pointers (void * _sn1, void * _sn2) compare_pointers (void *_sn1, void *_sn2)
{ {
pointer_info *sn1, *sn2; pointer_info *sn1, *sn2;
...@@ -238,7 +238,7 @@ compare_pointers (void * _sn1, void * _sn2) ...@@ -238,7 +238,7 @@ compare_pointers (void * _sn1, void * _sn2)
module. */ module. */
static int static int
compare_integers (void * _sn1, void * _sn2) compare_integers (void *_sn1, void *_sn2)
{ {
pointer_info *sn1, *sn2; pointer_info *sn1, *sn2;
...@@ -366,7 +366,7 @@ get_integer (int integer) ...@@ -366,7 +366,7 @@ get_integer (int integer)
/* Recursive function to find a pointer within a tree by brute force. */ /* Recursive function to find a pointer within a tree by brute force. */
static pointer_info * static pointer_info *
fp2 (pointer_info * p, const void *target) fp2 (pointer_info *p, const void *target)
{ {
pointer_info *q; pointer_info *q;
...@@ -390,14 +390,13 @@ fp2 (pointer_info * p, const void *target) ...@@ -390,14 +390,13 @@ fp2 (pointer_info * p, const void *target)
static pointer_info * static pointer_info *
find_pointer2 (void *p) find_pointer2 (void *p)
{ {
return fp2 (pi_root, p); return fp2 (pi_root, p);
} }
/* Resolve any fixups using a known pointer. */ /* Resolve any fixups using a known pointer. */
static void static void
resolve_fixups (fixup_t *f, void * gp) resolve_fixups (fixup_t *f, void *gp)
{ {
fixup_t *next; fixup_t *next;
...@@ -409,12 +408,13 @@ resolve_fixups (fixup_t *f, void * gp) ...@@ -409,12 +408,13 @@ resolve_fixups (fixup_t *f, void * gp)
} }
} }
/* Call here during module reading when we know what pointer to /* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at associate with an integer. Any fixups that exist are resolved at
this time. */ this time. */
static void static void
associate_integer_pointer (pointer_info * p, void *gp) associate_integer_pointer (pointer_info *p, void *gp)
{ {
if (p->u.pointer != NULL) if (p->u.pointer != NULL)
gfc_internal_error ("associate_integer_pointer(): Already associated"); gfc_internal_error ("associate_integer_pointer(): Already associated");
...@@ -577,7 +577,7 @@ gfc_match_use (void) ...@@ -577,7 +577,7 @@ gfc_match_use (void)
tail = new; tail = new;
/* See what kind of interface we're dealing with. Assume it is /* See what kind of interface we're dealing with. Assume it is
not an operator. */ not an operator. */
new->operator = INTRINSIC_NONE; new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
goto cleanup; goto cleanup;
...@@ -681,6 +681,7 @@ find_use_name_n (const char *name, int *inst) ...@@ -681,6 +681,7 @@ find_use_name_n (const char *name, int *inst)
return (u->local_name[0] != '\0') ? u->local_name : name; return (u->local_name[0] != '\0') ? u->local_name : name;
} }
/* Given a name, return the name under which to load this symbol. /* Given a name, return the name under which to load this symbol.
Returns NULL if this symbol shouldn't be loaded. */ Returns NULL if this symbol shouldn't be loaded. */
...@@ -691,8 +692,8 @@ find_use_name (const char *name) ...@@ -691,8 +692,8 @@ find_use_name (const char *name)
return find_use_name_n (name, &i); 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 static int
number_use_names (const char *name) number_use_names (const char *name)
...@@ -745,7 +746,7 @@ static true_name *true_name_root; ...@@ -745,7 +746,7 @@ static true_name *true_name_root;
/* Compare two true_name structures. */ /* Compare two true_name structures. */
static int static int
compare_true_names (void * _t1, void * _t2) compare_true_names (void *_t1, void *_t2)
{ {
true_name *t1, *t2; true_name *t1, *t2;
int c; int c;
...@@ -782,7 +783,7 @@ find_true_name (const char *name, const char *module) ...@@ -782,7 +783,7 @@ find_true_name (const char *name, const char *module)
p = true_name_root; p = true_name_root;
while (p != NULL) while (p != NULL)
{ {
c = compare_true_names ((void *)(&t), (void *) p); c = compare_true_names ((void *) (&t), (void *) p);
if (c == 0) if (c == 0)
return p->sym; return p->sym;
...@@ -793,11 +794,10 @@ find_true_name (const char *name, const char *module) ...@@ -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 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
it. */
static void static void
add_true_name (gfc_symbol * sym) add_true_name (gfc_symbol *sym)
{ {
true_name *t; true_name *t;
...@@ -812,9 +812,8 @@ add_true_name (gfc_symbol * sym) ...@@ -812,9 +812,8 @@ add_true_name (gfc_symbol * sym)
recursively traversing the current namespace. */ recursively traversing the current namespace. */
static void static void
build_tnt (gfc_symtree * st) build_tnt (gfc_symtree *st)
{ {
if (st == NULL) if (st == NULL)
return; return;
...@@ -834,7 +833,6 @@ static void ...@@ -834,7 +833,6 @@ static void
init_true_name_tree (void) init_true_name_tree (void)
{ {
true_name_root = NULL; true_name_root = NULL;
build_tnt (gfc_current_ns->sym_root); build_tnt (gfc_current_ns->sym_root);
} }
...@@ -842,9 +840,8 @@ init_true_name_tree (void) ...@@ -842,9 +840,8 @@ init_true_name_tree (void)
/* Recursively free a true name tree node. */ /* Recursively free a true name tree node. */
static void static void
free_true_name (true_name * t) free_true_name (true_name *t)
{ {
if (t == NULL) if (t == NULL)
return; return;
free_true_name (t->left); free_true_name (t->left);
...@@ -911,9 +908,8 @@ bad_module (const char *msgid) ...@@ -911,9 +908,8 @@ bad_module (const char *msgid)
/* Set the module's input pointer. */ /* Set the module's input pointer. */
static void static void
set_module_locus (module_locus * m) set_module_locus (module_locus *m)
{ {
module_column = m->column; module_column = m->column;
module_line = m->line; module_line = m->line;
fsetpos (module_fp, &m->pos); fsetpos (module_fp, &m->pos);
...@@ -923,9 +919,8 @@ set_module_locus (module_locus * m) ...@@ -923,9 +919,8 @@ set_module_locus (module_locus * m)
/* Get the module's input pointer so that we can restore it later. */ /* Get the module's input pointer so that we can restore it later. */
static void static void
get_module_locus (module_locus * m) get_module_locus (module_locus *m)
{ {
m->column = module_column; m->column = module_column;
m->line = module_line; m->line = module_line;
fgetpos (module_fp, &m->pos); fgetpos (module_fp, &m->pos);
...@@ -978,14 +973,14 @@ parse_string (void) ...@@ -978,14 +973,14 @@ parse_string (void)
bad_module ("Unexpected end of module in string constant"); bad_module ("Unexpected end of module in string constant");
if (c != '\'') if (c != '\'')
{ {
len++; len++;
continue; continue;
} }
c = module_char (); c = module_char ();
if (c == '\'') if (c == '\'')
{ {
len++; len++;
continue; continue;
} }
...@@ -1001,12 +996,12 @@ parse_string (void) ...@@ -1001,12 +996,12 @@ parse_string (void)
{ {
c = module_char (); c = module_char ();
if (c == '\'') if (c == '\'')
module_char (); /* Guaranteed to be another \' */ module_char (); /* Guaranteed to be another \' */
*p++ = c; *p++ = c;
} }
module_char (); /* Terminating \' */ module_char (); /* Terminating \' */
*p = '\0'; /* C-style string for debug purposes */ *p = '\0'; /* C-style string for debug purposes. */
} }
...@@ -1239,7 +1234,7 @@ require_atom (atom_type type) ...@@ -1239,7 +1234,7 @@ require_atom (atom_type type)
be one of the strings in the array. We return the enum value. */ be one of the strings in the array. We return the enum value. */
static int static int
find_enum (const mstring * m) find_enum (const mstring *m)
{ {
int i; int i;
...@@ -1260,7 +1255,6 @@ find_enum (const mstring * m) ...@@ -1260,7 +1255,6 @@ find_enum (const mstring * m)
static void static void
write_char (char out) write_char (char out)
{ {
if (fputc (out, module_fp) == EOF) if (fputc (out, module_fp) == EOF)
gfc_fatal_error ("Error writing modules file: %s", strerror (errno)); gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
...@@ -1362,9 +1356,8 @@ static void mio_symtree_ref (gfc_symtree **); ...@@ -1362,9 +1356,8 @@ static void mio_symtree_ref (gfc_symtree **);
pointer because enums are sometimes inside bitfields. */ pointer because enums are sometimes inside bitfields. */
static int static int
mio_name (int t, const mstring * m) mio_name (int t, const mstring *m)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
write_atom (ATOM_NAME, gfc_code2string (m, t)); write_atom (ATOM_NAME, gfc_code2string (m, t));
else else
...@@ -1380,16 +1373,15 @@ mio_name (int t, const mstring * m) ...@@ -1380,16 +1373,15 @@ mio_name (int t, const mstring * m)
#define DECL_MIO_NAME(TYPE) \ #define DECL_MIO_NAME(TYPE) \
static inline 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 #define MIO_NAME(TYPE) mio_name_##TYPE
static void static void
mio_lparen (void) mio_lparen (void)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
write_atom (ATOM_LPAREN, NULL); write_atom (ATOM_LPAREN, NULL);
else else
...@@ -1400,7 +1392,6 @@ mio_lparen (void) ...@@ -1400,7 +1392,6 @@ mio_lparen (void)
static void static void
mio_rparen (void) mio_rparen (void)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
write_atom (ATOM_RPAREN, NULL); write_atom (ATOM_RPAREN, NULL);
else else
...@@ -1411,7 +1402,6 @@ mio_rparen (void) ...@@ -1411,7 +1402,6 @@ mio_rparen (void)
static void static void
mio_integer (int *ip) mio_integer (int *ip)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
write_atom (ATOM_INTEGER, ip); write_atom (ATOM_INTEGER, ip);
else else
...@@ -1472,7 +1462,6 @@ mio_pool_string (const char **stringp) ...@@ -1472,7 +1462,6 @@ mio_pool_string (const char **stringp)
static void static void
mio_internal_string (char *string) mio_internal_string (char *string)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
write_atom (ATOM_STRING, string); write_atom (ATOM_STRING, string);
else else
...@@ -1529,18 +1518,18 @@ static const mstring attr_bits[] = ...@@ -1529,18 +1518,18 @@ static const mstring attr_bits[] =
}; };
/* Specialization of mio_name. */ /* Specialization of mio_name. */
DECL_MIO_NAME(ab_attribute) DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME(ar_type) DECL_MIO_NAME (ar_type)
DECL_MIO_NAME(array_type) DECL_MIO_NAME (array_type)
DECL_MIO_NAME(bt) DECL_MIO_NAME (bt)
DECL_MIO_NAME(expr_t) DECL_MIO_NAME (expr_t)
DECL_MIO_NAME(gfc_access) DECL_MIO_NAME (gfc_access)
DECL_MIO_NAME(gfc_intrinsic_op) DECL_MIO_NAME (gfc_intrinsic_op)
DECL_MIO_NAME(ifsrc) DECL_MIO_NAME (ifsrc)
DECL_MIO_NAME(procedure_type) DECL_MIO_NAME (procedure_type)
DECL_MIO_NAME(ref_type) DECL_MIO_NAME (ref_type)
DECL_MIO_NAME(sym_flavor) DECL_MIO_NAME (sym_flavor)
DECL_MIO_NAME(sym_intent) DECL_MIO_NAME (sym_intent)
#undef DECL_MIO_NAME #undef DECL_MIO_NAME
/* Symbol attributes are stored in list with the first three elements /* Symbol attributes are stored in list with the first three elements
...@@ -1550,86 +1539,85 @@ DECL_MIO_NAME(sym_intent) ...@@ -1550,86 +1539,85 @@ DECL_MIO_NAME(sym_intent)
written. */ written. */
static void static void
mio_symbol_attribute (symbol_attribute * attr) mio_symbol_attribute (symbol_attribute *attr)
{ {
atom_type t; atom_type t;
mio_lparen (); mio_lparen ();
attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors); attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
attr->intent = MIO_NAME(sym_intent) (attr->intent, intents); attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures); attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types); attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
{ {
if (attr->allocatable) if (attr->allocatable)
MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits); MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
if (attr->dimension) if (attr->dimension)
MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits); MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->external) if (attr->external)
MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits); MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
if (attr->intrinsic) if (attr->intrinsic)
MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits); MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
if (attr->optional) if (attr->optional)
MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits); MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
if (attr->pointer) if (attr->pointer)
MIO_NAME(ab_attribute) (AB_POINTER, attr_bits); MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
if (attr->protected) if (attr->protected)
MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits); MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
if (attr->save) if (attr->save)
MIO_NAME(ab_attribute) (AB_SAVE, attr_bits); MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
if (attr->value) if (attr->value)
MIO_NAME(ab_attribute) (AB_VALUE, attr_bits); MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
if (attr->volatile_) if (attr->volatile_)
MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits); MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
if (attr->target) if (attr->target)
MIO_NAME(ab_attribute) (AB_TARGET, attr_bits); MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
if (attr->threadprivate) if (attr->threadprivate)
MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits); MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy) if (attr->dummy)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits); MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result) 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. */ /* We deliberately don't preserve the "entry" flag. */
if (attr->data) if (attr->data)
MIO_NAME(ab_attribute) (AB_DATA, attr_bits); MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
if (attr->in_namelist) 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) 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) if (attr->function)
MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits); MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
if (attr->subroutine) if (attr->subroutine)
MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits); MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
if (attr->generic) if (attr->generic)
MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits); MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
if (attr->sequence) if (attr->sequence)
MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits); MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
if (attr->elemental) if (attr->elemental)
MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits); MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure) if (attr->pure)
MIO_NAME(ab_attribute) (AB_PURE, attr_bits); MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->recursive) if (attr->recursive)
MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits); MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit) 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) 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) 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) if (attr->alloc_comp)
MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits); MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
mio_rparen (); mio_rparen ();
} }
else else
{ {
for (;;) for (;;)
{ {
t = parse_atom (); t = parse_atom ();
...@@ -1712,9 +1700,9 @@ mio_symbol_attribute (symbol_attribute * attr) ...@@ -1712,9 +1700,9 @@ mio_symbol_attribute (symbol_attribute * attr)
case AB_RECURSIVE: case AB_RECURSIVE:
attr->recursive = 1; attr->recursive = 1;
break; break;
case AB_ALWAYS_EXPLICIT: case AB_ALWAYS_EXPLICIT:
attr->always_explicit = 1; attr->always_explicit = 1;
break; break;
case AB_CRAY_POINTER: case AB_CRAY_POINTER:
attr->cray_pointer = 1; attr->cray_pointer = 1;
break; break;
...@@ -1744,7 +1732,7 @@ static const mstring bt_types[] = { ...@@ -1744,7 +1732,7 @@ static const mstring bt_types[] = {
static void static void
mio_charlen (gfc_charlen ** clp) mio_charlen (gfc_charlen **clp)
{ {
gfc_charlen *cl; gfc_charlen *cl;
...@@ -1758,7 +1746,6 @@ mio_charlen (gfc_charlen ** clp) ...@@ -1758,7 +1746,6 @@ mio_charlen (gfc_charlen ** clp)
} }
else else
{ {
if (peek_atom () != ATOM_RPAREN) if (peek_atom () != ATOM_RPAREN)
{ {
cl = gfc_get_charlen (); cl = gfc_get_charlen ();
...@@ -1779,7 +1766,7 @@ mio_charlen (gfc_charlen ** clp) ...@@ -1779,7 +1766,7 @@ mio_charlen (gfc_charlen ** clp)
within the namespace and corresponds to an illegal fortran name. */ within the namespace and corresponds to an illegal fortran name. */
static gfc_symtree * static gfc_symtree *
get_unique_symtree (gfc_namespace * ns) get_unique_symtree (gfc_namespace *ns)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0; static int serial = 0;
...@@ -1794,18 +1781,16 @@ get_unique_symtree (gfc_namespace * ns) ...@@ -1794,18 +1781,16 @@ get_unique_symtree (gfc_namespace * ns)
static int static int
check_unique_name (const char *name) check_unique_name (const char *name)
{ {
return *name == '@'; return *name == '@';
} }
static void static void
mio_typespec (gfc_typespec * ts) mio_typespec (gfc_typespec *ts)
{ {
mio_lparen (); 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) if (ts->type != BT_DERIVED)
mio_integer (&ts->kind); mio_integer (&ts->kind);
...@@ -1828,7 +1813,7 @@ static const mstring array_spec_types[] = { ...@@ -1828,7 +1813,7 @@ static const mstring array_spec_types[] = {
static void static void
mio_array_spec (gfc_array_spec ** asp) mio_array_spec (gfc_array_spec **asp)
{ {
gfc_array_spec *as; gfc_array_spec *as;
int i; int i;
...@@ -1853,7 +1838,7 @@ mio_array_spec (gfc_array_spec ** asp) ...@@ -1853,7 +1838,7 @@ mio_array_spec (gfc_array_spec ** asp)
} }
mio_integer (&as->rank); 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++) for (i = 0; i < as->rank; i++)
{ {
...@@ -1879,13 +1864,14 @@ static const mstring array_ref_types[] = { ...@@ -1879,13 +1864,14 @@ static const mstring array_ref_types[] = {
minit (NULL, -1) minit (NULL, -1)
}; };
static void static void
mio_array_ref (gfc_array_ref * ar) mio_array_ref (gfc_array_ref *ar)
{ {
int i; int i;
mio_lparen (); 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); mio_integer (&ar->dimen);
switch (ar->type) switch (ar->type)
...@@ -1976,7 +1962,7 @@ mio_pointer_ref (void *gp) ...@@ -1976,7 +1962,7 @@ mio_pointer_ref (void *gp)
the namespace and is not loaded again. */ the namespace and is not loaded again. */
static void 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]; char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_component *q; gfc_component *q;
...@@ -2020,7 +2006,7 @@ mio_component_ref (gfc_component ** cp, gfc_symbol * sym) ...@@ -2020,7 +2006,7 @@ mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
static void static void
mio_component (gfc_component * c) mio_component (gfc_component *c)
{ {
pointer_info *p; pointer_info *p;
int n; int n;
...@@ -2056,7 +2042,7 @@ mio_component (gfc_component * c) ...@@ -2056,7 +2042,7 @@ mio_component (gfc_component * c)
static void static void
mio_component_list (gfc_component ** cp) mio_component_list (gfc_component **cp)
{ {
gfc_component *c, *tail; gfc_component *c, *tail;
...@@ -2069,7 +2055,6 @@ mio_component_list (gfc_component ** cp) ...@@ -2069,7 +2055,6 @@ mio_component_list (gfc_component ** cp)
} }
else else
{ {
*cp = NULL; *cp = NULL;
tail = NULL; tail = NULL;
...@@ -2095,9 +2080,8 @@ mio_component_list (gfc_component ** cp) ...@@ -2095,9 +2080,8 @@ mio_component_list (gfc_component ** cp)
static void static void
mio_actual_arg (gfc_actual_arglist * a) mio_actual_arg (gfc_actual_arglist *a)
{ {
mio_lparen (); mio_lparen ();
mio_pool_string (&a->name); mio_pool_string (&a->name);
mio_expr (&a->expr); mio_expr (&a->expr);
...@@ -2106,7 +2090,7 @@ mio_actual_arg (gfc_actual_arglist * a) ...@@ -2106,7 +2090,7 @@ mio_actual_arg (gfc_actual_arglist * a)
static void static void
mio_actual_arglist (gfc_actual_arglist ** ap) mio_actual_arglist (gfc_actual_arglist **ap)
{ {
gfc_actual_arglist *a, *tail; gfc_actual_arglist *a, *tail;
...@@ -2146,7 +2130,7 @@ mio_actual_arglist (gfc_actual_arglist ** ap) ...@@ -2146,7 +2130,7 @@ mio_actual_arglist (gfc_actual_arglist ** ap)
/* Read and write formal argument lists. */ /* Read and write formal argument lists. */
static void static void
mio_formal_arglist (gfc_symbol * sym) mio_formal_arglist (gfc_symbol *sym)
{ {
gfc_formal_arglist *f, *tail; gfc_formal_arglist *f, *tail;
...@@ -2183,7 +2167,7 @@ mio_formal_arglist (gfc_symbol * sym) ...@@ -2183,7 +2167,7 @@ mio_formal_arglist (gfc_symbol * sym)
/* Save or restore a reference to a symbol node. */ /* Save or restore a reference to a symbol node. */
void void
mio_symbol_ref (gfc_symbol ** symp) mio_symbol_ref (gfc_symbol **symp)
{ {
pointer_info *p; pointer_info *p;
...@@ -2207,7 +2191,7 @@ mio_symbol_ref (gfc_symbol ** symp) ...@@ -2207,7 +2191,7 @@ mio_symbol_ref (gfc_symbol ** symp)
/* Save or restore a reference to a symtree node. */ /* Save or restore a reference to a symtree node. */
static void static void
mio_symtree_ref (gfc_symtree ** stp) mio_symtree_ref (gfc_symtree **stp)
{ {
pointer_info *p; pointer_info *p;
fixup_t *f; fixup_t *f;
...@@ -2224,29 +2208,30 @@ mio_symtree_ref (gfc_symtree ** stp) ...@@ -2224,29 +2208,30 @@ mio_symtree_ref (gfc_symtree ** stp)
return; return;
if (p->type == P_UNKNOWN) if (p->type == P_UNKNOWN)
p->type = P_SYMBOL; p->type = P_SYMBOL;
if (p->u.rsym.state == UNUSED) if (p->u.rsym.state == UNUSED)
p->u.rsym.state = NEEDED; p->u.rsym.state = NEEDED;
if (p->u.rsym.symtree != NULL) if (p->u.rsym.symtree != NULL)
{ {
*stp = p->u.rsym.symtree; *stp = p->u.rsym.symtree;
} }
else else
{ {
f = gfc_getmem (sizeof (fixup_t)); f = gfc_getmem (sizeof (fixup_t));
f->next = p->u.rsym.stfixup; f->next = p->u.rsym.stfixup;
p->u.rsym.stfixup = f; p->u.rsym.stfixup = f;
f->pointer = (void **)stp; f->pointer = (void **)stp;
} }
} }
} }
static void static void
mio_iterator (gfc_iterator ** ip) mio_iterator (gfc_iterator **ip)
{ {
gfc_iterator *iter; gfc_iterator *iter;
...@@ -2280,9 +2265,8 @@ done: ...@@ -2280,9 +2265,8 @@ done:
} }
static void static void
mio_constructor (gfc_constructor ** cp) mio_constructor (gfc_constructor **cp)
{ {
gfc_constructor *c, *tail; gfc_constructor *c, *tail;
...@@ -2300,7 +2284,6 @@ mio_constructor (gfc_constructor ** cp) ...@@ -2300,7 +2284,6 @@ mio_constructor (gfc_constructor ** cp)
} }
else else
{ {
*cp = NULL; *cp = NULL;
tail = NULL; tail = NULL;
...@@ -2326,7 +2309,6 @@ mio_constructor (gfc_constructor ** cp) ...@@ -2326,7 +2309,6 @@ mio_constructor (gfc_constructor ** cp)
} }
static const mstring ref_types[] = { static const mstring ref_types[] = {
minit ("ARRAY", REF_ARRAY), minit ("ARRAY", REF_ARRAY),
minit ("COMPONENT", REF_COMPONENT), minit ("COMPONENT", REF_COMPONENT),
...@@ -2336,14 +2318,14 @@ static const mstring ref_types[] = { ...@@ -2336,14 +2318,14 @@ static const mstring ref_types[] = {
static void static void
mio_ref (gfc_ref ** rp) mio_ref (gfc_ref **rp)
{ {
gfc_ref *r; gfc_ref *r;
mio_lparen (); mio_lparen ();
r = *rp; 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) switch (r->type)
{ {
...@@ -2368,7 +2350,7 @@ mio_ref (gfc_ref ** rp) ...@@ -2368,7 +2350,7 @@ mio_ref (gfc_ref ** rp)
static void static void
mio_ref_list (gfc_ref ** rp) mio_ref_list (gfc_ref **rp)
{ {
gfc_ref *ref, *head, *tail; gfc_ref *ref, *head, *tail;
...@@ -2406,7 +2388,7 @@ mio_ref_list (gfc_ref ** rp) ...@@ -2406,7 +2388,7 @@ mio_ref_list (gfc_ref ** rp)
/* Read and write an integer value. */ /* Read and write an integer value. */
static void static void
mio_gmp_integer (mpz_t * integer) mio_gmp_integer (mpz_t *integer)
{ {
char *p; char *p;
...@@ -2420,7 +2402,6 @@ mio_gmp_integer (mpz_t * integer) ...@@ -2420,7 +2402,6 @@ mio_gmp_integer (mpz_t * integer)
bad_module ("Error converting integer"); bad_module ("Error converting integer");
gfc_free (atom_string); gfc_free (atom_string);
} }
else else
{ {
...@@ -2432,7 +2413,7 @@ mio_gmp_integer (mpz_t * integer) ...@@ -2432,7 +2413,7 @@ mio_gmp_integer (mpz_t * integer)
static void static void
mio_gmp_real (mpfr_t * real) mio_gmp_real (mpfr_t *real)
{ {
mp_exp_t exponent; mp_exp_t exponent;
char *p; char *p;
...@@ -2445,7 +2426,6 @@ mio_gmp_real (mpfr_t * real) ...@@ -2445,7 +2426,6 @@ mio_gmp_real (mpfr_t * real)
mpfr_init (*real); mpfr_init (*real);
mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE); mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string); gfc_free (atom_string);
} }
else else
{ {
...@@ -2473,7 +2453,7 @@ mio_gmp_real (mpfr_t * real) ...@@ -2473,7 +2453,7 @@ mio_gmp_real (mpfr_t * real)
/* Save and restore the shape of an array constructor. */ /* Save and restore the shape of an array constructor. */
static void static void
mio_shape (mpz_t ** pshape, int rank) mio_shape (mpz_t **pshape, int rank)
{ {
mpz_t *shape; mpz_t *shape;
atom_type t; atom_type t;
...@@ -2573,13 +2553,13 @@ fix_mio_expr (gfc_expr *e) ...@@ -2573,13 +2553,13 @@ fix_mio_expr (gfc_expr *e)
yet. If so, the latter should be written. */ yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name(e->symtree->name)) if (e->symtree->n.sym && check_unique_name(e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root, 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 /* 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. */ new symbol is a dummy argument, do not do the promotion. */
if (ns_st && ns_st->n.sym if (ns_st && ns_st->n.sym
&& ns_st->n.sym->attr.flavor != FL_MODULE && ns_st->n.sym->attr.flavor != FL_MODULE
&& !e->symtree->n.sym->attr.dummy) && !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st; e->symtree = ns_st;
} }
else if (e->expr_type == EXPR_FUNCTION && e->value.function.name) else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
...@@ -2588,8 +2568,8 @@ fix_mio_expr (gfc_expr *e) ...@@ -2588,8 +2568,8 @@ fix_mio_expr (gfc_expr *e)
expression, in one use associated module, can fail to be expression, in one use associated module, can fail to be
coupled to its symtree when used in a specification coupled to its symtree when used in a specification
expression in another module. */ expression in another module. */
fname = e->value.function.esym ? e->value.function.esym->name : fname = e->value.function.esym ? e->value.function.esym->name
e->value.function.isym->name; : e->value.function.isym->name;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
} }
} }
...@@ -2599,7 +2579,7 @@ fix_mio_expr (gfc_expr *e) ...@@ -2599,7 +2579,7 @@ fix_mio_expr (gfc_expr *e)
NULL expression. */ NULL expression. */
static void static void
mio_expr (gfc_expr ** ep) mio_expr (gfc_expr **ep)
{ {
gfc_expr *e; gfc_expr *e;
atom_type t; atom_type t;
...@@ -2616,8 +2596,7 @@ mio_expr (gfc_expr ** ep) ...@@ -2616,8 +2596,7 @@ mio_expr (gfc_expr ** ep)
} }
e = *ep; e = *ep;
MIO_NAME(expr_t) (e->expr_type, expr_types); MIO_NAME (expr_t) (e->expr_type, expr_types);
} }
else else
{ {
...@@ -2645,7 +2624,7 @@ mio_expr (gfc_expr ** ep) ...@@ -2645,7 +2624,7 @@ mio_expr (gfc_expr ** ep)
{ {
case EXPR_OP: case EXPR_OP:
e->value.op.operator 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) switch (e->value.op.operator)
{ {
...@@ -2696,7 +2675,6 @@ mio_expr (gfc_expr ** ep) ...@@ -2696,7 +2675,6 @@ mio_expr (gfc_expr ** ep)
mio_symbol_ref (&e->value.function.esym); mio_symbol_ref (&e->value.function.esym);
else else
write_atom (ATOM_STRING, e->value.function.isym->name); write_atom (ATOM_STRING, e->value.function.isym->name);
} }
else else
{ {
...@@ -2723,8 +2701,8 @@ mio_expr (gfc_expr ** ep) ...@@ -2723,8 +2701,8 @@ mio_expr (gfc_expr ** ep)
break; break;
case EXPR_SUBSTRING: case EXPR_SUBSTRING:
e->value.character.string = (char *) e->value.character.string
mio_allocated_string (e->value.character.string); = (char *) mio_allocated_string (e->value.character.string);
mio_ref_list (&e->ref); mio_ref_list (&e->ref);
break; break;
...@@ -2742,12 +2720,12 @@ mio_expr (gfc_expr ** ep) ...@@ -2742,12 +2720,12 @@ mio_expr (gfc_expr ** ep)
break; break;
case BT_REAL: case BT_REAL:
gfc_set_model_kind (e->ts.kind); gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real); mio_gmp_real (&e->value.real);
break; break;
case BT_COMPLEX: 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.r);
mio_gmp_real (&e->value.complex.i); mio_gmp_real (&e->value.complex.i);
break; break;
...@@ -2758,8 +2736,8 @@ mio_expr (gfc_expr ** ep) ...@@ -2758,8 +2736,8 @@ mio_expr (gfc_expr ** ep)
case BT_CHARACTER: case BT_CHARACTER:
mio_integer (&e->value.character.length); mio_integer (&e->value.character.length);
e->value.character.string = (char *) e->value.character.string
mio_allocated_string (e->value.character.string); = (char *) mio_allocated_string (e->value.character.string);
break; break;
default: default:
...@@ -2779,7 +2757,7 @@ mio_expr (gfc_expr ** ep) ...@@ -2779,7 +2757,7 @@ mio_expr (gfc_expr ** ep)
/* Read and write namelists */ /* Read and write namelists */
static void static void
mio_namelist (gfc_symbol * sym) mio_namelist (gfc_symbol *sym)
{ {
gfc_namelist *n, *m; gfc_namelist *n, *m;
const char *check_name; const char *check_name;
...@@ -2800,9 +2778,8 @@ mio_namelist (gfc_symbol * sym) ...@@ -2800,9 +2778,8 @@ mio_namelist (gfc_symbol * sym)
{ {
check_name = find_use_name (sym->name); check_name = find_use_name (sym->name);
if (check_name && strcmp (check_name, sym->name) != 0) if (check_name && strcmp (check_name, sym->name) != 0)
gfc_error("Namelist %s cannot be renamed by USE" gfc_error ("Namelist %s cannot be renamed by USE "
" association to %s", "association to %s", sym->name, check_name);
sym->name, check_name);
} }
m = NULL; m = NULL;
...@@ -2831,7 +2808,7 @@ mio_namelist (gfc_symbol * sym) ...@@ -2831,7 +2808,7 @@ mio_namelist (gfc_symbol * sym)
be done later when all symbols have been loaded. */ be done later when all symbols have been loaded. */
static void static void
mio_interface_rest (gfc_interface ** ip) mio_interface_rest (gfc_interface **ip)
{ {
gfc_interface *tail, *p; gfc_interface *tail, *p;
...@@ -2843,7 +2820,6 @@ mio_interface_rest (gfc_interface ** ip) ...@@ -2843,7 +2820,6 @@ mio_interface_rest (gfc_interface ** ip)
} }
else else
{ {
if (*ip == NULL) if (*ip == NULL)
tail = NULL; tail = NULL;
else else
...@@ -2878,9 +2854,8 @@ mio_interface_rest (gfc_interface ** ip) ...@@ -2878,9 +2854,8 @@ mio_interface_rest (gfc_interface ** ip)
/* Save/restore a nameless operator interface. */ /* Save/restore a nameless operator interface. */
static void static void
mio_interface (gfc_interface ** ip) mio_interface (gfc_interface **ip)
{ {
mio_lparen (); mio_lparen ();
mio_interface_rest (ip); mio_interface_rest (ip);
} }
...@@ -2890,20 +2865,17 @@ mio_interface (gfc_interface ** ip) ...@@ -2890,20 +2865,17 @@ mio_interface (gfc_interface ** ip)
static void static void
mio_symbol_interface (const char **name, const char **module, mio_symbol_interface (const char **name, const char **module,
gfc_interface ** ip) gfc_interface **ip)
{ {
mio_lparen (); mio_lparen ();
mio_pool_string (name); mio_pool_string (name);
mio_pool_string (module); mio_pool_string (module);
mio_interface_rest (ip); mio_interface_rest (ip);
} }
static void static void
mio_namespace_ref (gfc_namespace ** nsp) mio_namespace_ref (gfc_namespace **nsp)
{ {
gfc_namespace *ns; gfc_namespace *ns;
pointer_info *p; pointer_info *p;
...@@ -2915,7 +2887,7 @@ mio_namespace_ref (gfc_namespace ** nsp) ...@@ -2915,7 +2887,7 @@ mio_namespace_ref (gfc_namespace ** nsp)
if (iomode == IO_INPUT && p->integer != 0) if (iomode == IO_INPUT && p->integer != 0)
{ {
ns = (gfc_namespace *)p->u.pointer; ns = (gfc_namespace *) p->u.pointer;
if (ns == NULL) if (ns == NULL)
{ {
ns = gfc_get_namespace (NULL, 0); ns = gfc_get_namespace (NULL, 0);
...@@ -2927,12 +2899,11 @@ mio_namespace_ref (gfc_namespace ** nsp) ...@@ -2927,12 +2899,11 @@ mio_namespace_ref (gfc_namespace ** nsp)
} }
/* Unlike most other routines, the address of the symbol node is /* Unlike most other routines, the address of the symbol node is already
already fixed on input and the name/module has already been filled fixed on input and the name/module has already been filled in. */
in. */
static void static void
mio_symbol (gfc_symbol * sym) mio_symbol (gfc_symbol *sym)
{ {
gfc_formal_arglist *formal; gfc_formal_arglist *formal;
...@@ -2985,8 +2956,8 @@ mio_symbol (gfc_symbol * sym) ...@@ -2985,8 +2956,8 @@ mio_symbol (gfc_symbol * sym)
mio_component_list (&sym->components); mio_component_list (&sym->components);
if (sym->components != NULL) if (sym->components != NULL)
sym->component_access = sym->component_access
MIO_NAME(gfc_access) (sym->component_access, access_types); = MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym); mio_namelist (sym);
mio_rparen (); mio_rparen ();
...@@ -3096,7 +3067,7 @@ load_generic_interfaces (void) ...@@ -3096,7 +3067,7 @@ load_generic_interfaces (void)
if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym)) if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
{ {
while (parse_atom () != ATOM_RPAREN); while (parse_atom () != ATOM_RPAREN);
continue; continue;
} }
if (sym == NULL) if (sym == NULL)
...@@ -3139,9 +3110,9 @@ load_generic_interfaces (void) ...@@ -3139,9 +3110,9 @@ load_generic_interfaces (void)
/* Load common blocks. */ /* Load common blocks. */
static void 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; gfc_common_head *p;
mio_lparen (); mio_lparen ();
...@@ -3162,45 +3133,46 @@ load_commons(void) ...@@ -3162,45 +3133,46 @@ load_commons(void)
p->threadprivate = 1; p->threadprivate = 1;
p->use_assoc = 1; p->use_assoc = 1;
mio_rparen(); mio_rparen ();
} }
mio_rparen(); mio_rparen ();
} }
/* load_equiv()-- Load equivalences. The flag in_load_equiv informs /* load_equiv()-- Load equivalences. The flag in_load_equiv informs
mio_expr_ref of this so that unused variables are not loaded and mio_expr_ref of this so that unused variables are not loaded and
so that the expression can be safely freed.*/ so that the expression can be safely freed.*/
static void static void
load_equiv(void) load_equiv (void)
{ {
gfc_equiv *head, *tail, *end, *eq; gfc_equiv *head, *tail, *end, *eq;
bool unused; bool unused;
mio_lparen(); mio_lparen ();
in_load_equiv = true; in_load_equiv = true;
end = gfc_current_ns->equiv; end = gfc_current_ns->equiv;
while(end != NULL && end->next != NULL) while (end != NULL && end->next != NULL)
end = end->next; end = end->next;
while(peek_atom() != ATOM_RPAREN) { while (peek_atom() != ATOM_RPAREN) {
mio_lparen(); mio_lparen ();
head = tail = NULL; head = tail = NULL;
while(peek_atom() != ATOM_RPAREN) while(peek_atom () != ATOM_RPAREN)
{ {
if (head == NULL) if (head == NULL)
head = tail = gfc_get_equiv(); head = tail = gfc_get_equiv ();
else else
{ {
tail->eq = gfc_get_equiv(); tail->eq = gfc_get_equiv ();
tail = tail->eq; tail = tail->eq;
} }
mio_pool_string(&tail->module); mio_pool_string (&tail->module);
mio_expr(&tail->expr); mio_expr (&tail->expr);
} }
/* Unused variables have no symtree. */ /* Unused variables have no symtree. */
...@@ -3232,10 +3204,10 @@ load_equiv(void) ...@@ -3232,10 +3204,10 @@ load_equiv(void)
if (head != NULL) if (head != NULL)
end = head; end = head;
mio_rparen(); mio_rparen ();
} }
mio_rparen(); mio_rparen ();
in_load_equiv = false; in_load_equiv = false;
} }
...@@ -3244,7 +3216,7 @@ load_equiv(void) ...@@ -3244,7 +3216,7 @@ load_equiv(void)
traversal, because the act of loading can alter the tree. */ traversal, because the act of loading can alter the tree. */
static int static int
load_needed (pointer_info * p) load_needed (pointer_info *p)
{ {
gfc_namespace *ns; gfc_namespace *ns;
pointer_info *q; pointer_info *q;
...@@ -3300,7 +3272,7 @@ load_needed (pointer_info * p) ...@@ -3300,7 +3272,7 @@ load_needed (pointer_info * p)
read. */ read. */
static void static void
read_cleanup (pointer_info * p) read_cleanup (pointer_info *p)
{ {
gfc_symtree *st; gfc_symtree *st;
pointer_info *q; pointer_info *q;
...@@ -3387,8 +3359,7 @@ read_module (void) ...@@ -3387,8 +3359,7 @@ read_module (void)
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
if (sym == NULL if (sym == NULL
|| (sym->attr.flavor == FL_VARIABLE || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
&& info->u.rsym.ns !=1))
continue; continue;
info->u.rsym.state = USED; info->u.rsym.state = USED;
...@@ -3438,9 +3409,11 @@ read_module (void) ...@@ -3438,9 +3409,11 @@ read_module (void)
} }
else else
{ {
/* Create a symtree node in the current namespace for this symbol. */ /* Create a symtree node in the current namespace for this
st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : symbol. */
gfc_new_symtree (&gfc_current_ns->sym_root, p); st = check_unique_name (p)
? get_unique_symtree (gfc_current_ns)
: gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous; st->ambiguous = ambiguous;
...@@ -3449,10 +3422,9 @@ read_module (void) ...@@ -3449,10 +3422,9 @@ read_module (void)
/* Create a symbol node if it doesn't already exist. */ /* Create a symbol node if it doesn't already exist. */
if (sym == NULL) if (sym == NULL)
{ {
sym = info->u.rsym.sym = info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
gfc_current_ns); sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module); sym->module = gfc_get_string (info->u.rsym.module);
} }
...@@ -3463,7 +3435,7 @@ read_module (void) ...@@ -3463,7 +3435,7 @@ read_module (void)
info->u.rsym.symtree = st; info->u.rsym.symtree = st;
if (info->u.rsym.state == UNUSED) if (info->u.rsym.state == UNUSED)
info->u.rsym.state = NEEDED; info->u.rsym.state = NEEDED;
info->u.rsym.referenced = 1; info->u.rsym.referenced = 1;
} }
} }
...@@ -3508,7 +3480,7 @@ read_module (void) ...@@ -3508,7 +3480,7 @@ read_module (void)
load_generic_interfaces (); load_generic_interfaces ();
load_commons (); load_commons ();
load_equiv(); load_equiv ();
/* At this point, we read those symbols that are needed but haven't /* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets been loaded yet. If one symbol requires another, the other gets
...@@ -3516,8 +3488,7 @@ read_module (void) ...@@ -3516,8 +3488,7 @@ read_module (void)
while (load_needed (pi_root)); while (load_needed (pi_root));
/* Make sure all elements of the rename-list were found in the /* Make sure all elements of the rename-list were found in the module. */
module. */
for (u = gfc_rename_list; u; u = u->next) for (u = gfc_rename_list; u; u = u->next)
{ {
...@@ -3533,15 +3504,14 @@ read_module (void) ...@@ -3533,15 +3504,14 @@ read_module (void)
if (u->operator == INTRINSIC_USER) if (u->operator == INTRINSIC_USER)
{ {
gfc_error gfc_error ("User operator '%s' referenced at %L not found "
("User operator '%s' referenced at %L not found in module '%s'", "in module '%s'", u->use_name, &u->where, module_name);
u->use_name, &u->where, module_name);
continue; continue;
} }
gfc_error gfc_error ("Intrinsic operator '%s' referenced at %L not found "
("Intrinsic operator '%s' referenced at %L not found in module " "in module '%s'", gfc_op2string (u->operator), &u->where,
"'%s'", gfc_op2string (u->operator), &u->where, module_name); module_name);
} }
gfc_check_interfaces (gfc_current_ns); gfc_check_interfaces (gfc_current_ns);
...@@ -3562,7 +3532,6 @@ read_module (void) ...@@ -3562,7 +3532,6 @@ read_module (void)
bool bool
gfc_check_access (gfc_access specific_access, gfc_access default_access) gfc_check_access (gfc_access specific_access, gfc_access default_access)
{ {
if (specific_access == ACCESS_PUBLIC) if (specific_access == ACCESS_PUBLIC)
return TRUE; return TRUE;
if (specific_access == ACCESS_PRIVATE) if (specific_access == ACCESS_PRIVATE)
...@@ -3584,23 +3553,23 @@ write_common (gfc_symtree *st) ...@@ -3584,23 +3553,23 @@ write_common (gfc_symtree *st)
if (st == NULL) if (st == NULL)
return; return;
write_common(st->left); write_common (st->left);
write_common(st->right); write_common (st->right);
mio_lparen(); mio_lparen ();
/* Write the unmangled name. */ /* Write the unmangled name. */
name = st->n.common->name; name = st->n.common->name;
mio_pool_string(&name); mio_pool_string (&name);
p = st->n.common; p = st->n.common;
mio_symbol_ref(&p->head); mio_symbol_ref (&p->head);
flags = p->saved ? 1 : 0; flags = p->saved ? 1 : 0;
if (p->threadprivate) flags |= 2; if (p->threadprivate) flags |= 2;
mio_integer(&flags); mio_integer (&flags);
mio_rparen(); mio_rparen ();
} }
/* Write the blank common block to the module */ /* Write the blank common block to the module */
...@@ -3614,47 +3583,49 @@ write_blank_common (void) ...@@ -3614,47 +3583,49 @@ write_blank_common (void)
if (gfc_current_ns->blank_common.head == NULL) if (gfc_current_ns->blank_common.head == NULL)
return; 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; saved = gfc_current_ns->blank_common.saved;
mio_integer(&saved); mio_integer (&saved);
mio_rparen(); mio_rparen ();
} }
/* Write equivalences to the module. */ /* Write equivalences to the module. */
static void static void
write_equiv(void) write_equiv (void)
{ {
gfc_equiv *eq, *e; gfc_equiv *eq, *e;
int num; int num;
num = 0; 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) if (e->module == NULL)
e->module = gfc_get_string("%s.eq.%d", module_name, num); e->module = gfc_get_string ("%s.eq.%d", module_name, num);
mio_allocated_string(e->module); mio_allocated_string (e->module);
mio_expr(&e->expr); mio_expr (&e->expr);
} }
num++; num++;
mio_rparen(); mio_rparen ();
} }
} }
/* Write a symbol to the module. */ /* Write a symbol to the module. */
static void 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) if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
...@@ -3676,7 +3647,7 @@ write_symbol (int n, gfc_symbol * sym) ...@@ -3676,7 +3647,7 @@ write_symbol (int n, gfc_symbol * sym)
according to the access specification. */ according to the access specification. */
static void static void
write_symbol0 (gfc_symtree * st) write_symbol0 (gfc_symtree *st)
{ {
gfc_symbol *sym; gfc_symbol *sym;
pointer_info *p; pointer_info *p;
...@@ -3720,9 +3691,8 @@ write_symbol0 (gfc_symtree * st) ...@@ -3720,9 +3691,8 @@ write_symbol0 (gfc_symtree * st)
symbol was written and pass that information upwards. */ symbol was written and pass that information upwards. */
static int static int
write_symbol1 (pointer_info * p) write_symbol1 (pointer_info *p)
{ {
if (p == NULL) if (p == NULL)
return 0; return 0;
...@@ -3744,7 +3714,7 @@ write_symbol1 (pointer_info * p) ...@@ -3744,7 +3714,7 @@ write_symbol1 (pointer_info * p)
/* Write operator interfaces associated with a symbol. */ /* Write operator interfaces associated with a symbol. */
static void static void
write_operator (gfc_user_op * uop) write_operator (gfc_user_op *uop)
{ {
static char nullstring[] = ""; static char nullstring[] = "";
const char *p = nullstring; const char *p = nullstring;
...@@ -3760,9 +3730,8 @@ write_operator (gfc_user_op * uop) ...@@ -3760,9 +3730,8 @@ write_operator (gfc_user_op * uop)
/* Write generic interfaces associated with a symbol. */ /* Write generic interfaces associated with a symbol. */
static void static void
write_generic (gfc_symbol * sym) write_generic (gfc_symbol *sym)
{ {
if (sym->generic == NULL if (sym->generic == NULL
|| !gfc_check_access (sym->attr.access, sym->ns->default_access)) || !gfc_check_access (sym->attr.access, sym->ns->default_access))
return; return;
...@@ -3775,7 +3744,7 @@ write_generic (gfc_symbol * sym) ...@@ -3775,7 +3744,7 @@ write_generic (gfc_symbol * sym)
static void static void
write_symtree (gfc_symtree * st) write_symtree (gfc_symtree *st)
{ {
gfc_symbol *sym; gfc_symbol *sym;
pointer_info *p; pointer_info *p;
...@@ -3840,10 +3809,11 @@ write_module (void) ...@@ -3840,10 +3809,11 @@ write_module (void)
write_char ('\n'); write_char ('\n');
write_char ('\n'); write_char ('\n');
mio_lparen(); mio_lparen ();
write_equiv(); write_equiv ();
mio_rparen(); mio_rparen ();
write_char('\n'); write_char('\n'); write_char ('\n');
write_char ('\n');
/* Write symbol information. First we traverse all symbols in the /* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written. primary namespace, writing those that need to be written.
...@@ -3935,8 +3905,8 @@ gfc_dump_module (const char *name, int dump_flag) ...@@ -3935,8 +3905,8 @@ gfc_dump_module (const char *name, int dump_flag)
static void static void
create_int_parameter (const char *name, int value, const char *modname) create_int_parameter (const char *name, int value, const char *modname)
{ {
gfc_symtree * tmp_symtree; gfc_symtree *tmp_symtree;
gfc_symbol * sym; gfc_symbol *sym;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL) if (tmp_symtree != NULL)
...@@ -3958,7 +3928,9 @@ create_int_parameter (const char *name, int value, const char *modname) ...@@ -3958,7 +3928,9 @@ create_int_parameter (const char *name, int value, const char *modname)
sym->attr.use_assoc = 1; sym->attr.use_assoc = 1;
} }
/* USE the ISO_FORTRAN_ENV intrinsic module. */ /* USE the ISO_FORTRAN_ENV intrinsic module. */
static void static void
use_iso_fortran_env_module (void) use_iso_fortran_env_module (void)
{ {
...@@ -4063,6 +4035,7 @@ use_iso_fortran_env_module (void) ...@@ -4063,6 +4035,7 @@ use_iso_fortran_env_module (void)
} }
} }
/* Process a USE directive. */ /* Process a USE directive. */
void void
...@@ -4073,8 +4046,8 @@ gfc_use_module (void) ...@@ -4073,8 +4046,8 @@ gfc_use_module (void)
int c, line, start; int c, line, start;
gfc_symtree *mod_symtree; gfc_symtree *mod_symtree;
filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION) filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
+ 1); + 1);
strcpy (filename, module_name); strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION); strcat (filename, MODULE_EXTENSION);
...@@ -4089,18 +4062,18 @@ gfc_use_module (void) ...@@ -4089,18 +4062,18 @@ gfc_use_module (void)
if (module_fp == NULL && !specified_nonint) if (module_fp == NULL && !specified_nonint)
{ {
if (strcmp (module_name, "iso_fortran_env") == 0 if (strcmp (module_name, "iso_fortran_env") == 0
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
"ISO_FORTRAN_ENV intrinsic module at %C") != FAILURE) "intrinsic module at %C") != FAILURE)
{ {
use_iso_fortran_env_module (); use_iso_fortran_env_module ();
return; return;
} }
module_fp = gfc_open_intrinsic_module (filename); module_fp = gfc_open_intrinsic_module (filename);
if (module_fp == NULL && specified_int) if (module_fp == NULL && specified_int)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C", gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
module_name); module_name);
} }
if (module_fp == NULL) if (module_fp == NULL)
...@@ -4131,9 +4104,9 @@ gfc_use_module (void) ...@@ -4131,9 +4104,9 @@ gfc_use_module (void)
if (start++ < 2) if (start++ < 2)
parse_name (c); parse_name (c);
if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) 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 " gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
"file", filename); "file", filename);
if (c == '\n') if (c == '\n')
line++; line++;
...@@ -4162,7 +4135,6 @@ gfc_use_module (void) ...@@ -4162,7 +4135,6 @@ gfc_use_module (void)
void void
gfc_module_init_2 (void) gfc_module_init_2 (void)
{ {
last_atom = ATOM_LPAREN; last_atom = ATOM_LPAREN;
} }
...@@ -4170,6 +4142,5 @@ gfc_module_init_2 (void) ...@@ -4170,6 +4142,5 @@ gfc_module_init_2 (void)
void void
gfc_module_done_2 (void) gfc_module_done_2 (void)
{ {
free_rename (); free_rename ();
} }
gcc/fortran/openmp.c
/* OpenMP directive matching and resolving. /* 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 Contributed by Jakub Jelinek
This file is part of GCC. This file is part of GCC.
...@@ -19,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "flags.h" #include "flags.h"
...@@ -410,6 +410,7 @@ gfc_match_omp_parallel (void) ...@@ -410,6 +410,7 @@ gfc_match_omp_parallel (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_critical (void) gfc_match_omp_critical (void)
{ {
...@@ -424,6 +425,7 @@ gfc_match_omp_critical (void) ...@@ -424,6 +425,7 @@ gfc_match_omp_critical (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_do (void) gfc_match_omp_do (void)
{ {
...@@ -435,6 +437,7 @@ gfc_match_omp_do (void) ...@@ -435,6 +437,7 @@ gfc_match_omp_do (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_flush (void) gfc_match_omp_flush (void)
{ {
...@@ -450,6 +453,7 @@ gfc_match_omp_flush (void) ...@@ -450,6 +453,7 @@ gfc_match_omp_flush (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_threadprivate (void) gfc_match_omp_threadprivate (void)
{ {
...@@ -478,8 +482,8 @@ gfc_match_omp_threadprivate (void) ...@@ -478,8 +482,8 @@ gfc_match_omp_threadprivate (void)
{ {
case MATCH_YES: case MATCH_YES:
if (sym->attr.in_common) if (sym->attr.in_common)
gfc_error_now ("Threadprivate variable at %C is an element of" gfc_error_now ("Threadprivate variable at %C is an element of "
" a COMMON block"); "a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name, else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE) &sym->declared_at) == FAILURE)
goto cleanup; goto cleanup;
...@@ -525,6 +529,7 @@ cleanup: ...@@ -525,6 +529,7 @@ cleanup:
return MATCH_ERROR; return MATCH_ERROR;
} }
match match
gfc_match_omp_parallel_do (void) gfc_match_omp_parallel_do (void)
{ {
...@@ -537,6 +542,7 @@ gfc_match_omp_parallel_do (void) ...@@ -537,6 +542,7 @@ gfc_match_omp_parallel_do (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_parallel_sections (void) gfc_match_omp_parallel_sections (void)
{ {
...@@ -549,6 +555,7 @@ gfc_match_omp_parallel_sections (void) ...@@ -549,6 +555,7 @@ gfc_match_omp_parallel_sections (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_parallel_workshare (void) gfc_match_omp_parallel_workshare (void)
{ {
...@@ -560,6 +567,7 @@ gfc_match_omp_parallel_workshare (void) ...@@ -560,6 +567,7 @@ gfc_match_omp_parallel_workshare (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_sections (void) gfc_match_omp_sections (void)
{ {
...@@ -571,6 +579,7 @@ gfc_match_omp_sections (void) ...@@ -571,6 +579,7 @@ gfc_match_omp_sections (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_single (void) gfc_match_omp_single (void)
{ {
...@@ -583,6 +592,7 @@ gfc_match_omp_single (void) ...@@ -583,6 +592,7 @@ gfc_match_omp_single (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_workshare (void) gfc_match_omp_workshare (void)
{ {
...@@ -593,6 +603,7 @@ gfc_match_omp_workshare (void) ...@@ -593,6 +603,7 @@ gfc_match_omp_workshare (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_master (void) gfc_match_omp_master (void)
{ {
...@@ -603,6 +614,7 @@ gfc_match_omp_master (void) ...@@ -603,6 +614,7 @@ gfc_match_omp_master (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_ordered (void) gfc_match_omp_ordered (void)
{ {
...@@ -613,6 +625,7 @@ gfc_match_omp_ordered (void) ...@@ -613,6 +625,7 @@ gfc_match_omp_ordered (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_atomic (void) gfc_match_omp_atomic (void)
{ {
...@@ -623,6 +636,7 @@ gfc_match_omp_atomic (void) ...@@ -623,6 +636,7 @@ gfc_match_omp_atomic (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_barrier (void) gfc_match_omp_barrier (void)
{ {
...@@ -633,6 +647,7 @@ gfc_match_omp_barrier (void) ...@@ -633,6 +647,7 @@ gfc_match_omp_barrier (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_end_nowait (void) gfc_match_omp_end_nowait (void)
{ {
...@@ -646,6 +661,7 @@ gfc_match_omp_end_nowait (void) ...@@ -646,6 +661,7 @@ gfc_match_omp_end_nowait (void)
return MATCH_YES; return MATCH_YES;
} }
match match
gfc_match_omp_end_single (void) gfc_match_omp_end_single (void)
{ {
...@@ -663,6 +679,7 @@ gfc_match_omp_end_single (void) ...@@ -663,6 +679,7 @@ gfc_match_omp_end_single (void)
return MATCH_YES; return MATCH_YES;
} }
/* OpenMP directive resolving routines. */ /* OpenMP directive resolving routines. */
static void static void
...@@ -691,16 +708,16 @@ resolve_omp_clauses (gfc_code *code) ...@@ -691,16 +708,16 @@ resolve_omp_clauses (gfc_code *code)
gfc_expr *expr = omp_clauses->num_threads; gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0) || expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("NUM_THREADS clause at %L requires a scalar" gfc_error ("NUM_THREADS clause at %L requires a scalar "
" INTEGER expression", &expr->where); "INTEGER expression", &expr->where);
} }
if (omp_clauses->chunk_size) if (omp_clauses->chunk_size)
{ {
gfc_expr *expr = omp_clauses->chunk_size; gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0) || expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("SCHEDULE clause's chunk_size at %L requires" gfc_error ("SCHEDULE clause's chunk_size at %L requires "
" a scalar INTEGER expression", &expr->where); "a scalar INTEGER expression", &expr->where);
} }
/* Check that no symbol appears on multiple clauses, except that /* Check that no symbol appears on multiple clauses, except that
...@@ -774,19 +791,19 @@ resolve_omp_clauses (gfc_code *code) ...@@ -774,19 +791,19 @@ resolve_omp_clauses (gfc_code *code)
for (; n != NULL; n = n->next) for (; n != NULL; n = n->next)
{ {
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause" gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
" at %L", n->sym->name, &code->loc); "at %L", n->sym->name, &code->loc);
if (n->sym->attr.allocatable) if (n->sym->attr.allocatable)
gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE" gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
" at %L", n->sym->name, &code->loc); "at %L", n->sym->name, &code->loc);
} }
break; break;
case OMP_LIST_SHARED: case OMP_LIST_SHARED:
for (; n != NULL; n = n->next) for (; n != NULL; n = n->next)
{ {
if (n->sym->attr.threadprivate) if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at" gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
" %L", n->sym->name, &code->loc); "%L", n->sym->name, &code->loc);
if (n->sym->attr.cray_pointee) if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L", gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, &code->loc); n->sym->name, &code->loc);
...@@ -819,8 +836,8 @@ resolve_omp_clauses (gfc_code *code) ...@@ -819,8 +836,8 @@ resolve_omp_clauses (gfc_code *code)
if (n->sym->attr.in_namelist if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST && (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST)) || list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable '%s' in %s clause is used in" gfc_error ("Variable '%s' in %s clause is used in "
" NAMELIST statement at %L", "NAMELIST statement at %L",
n->sym->name, name, &code->loc); n->sym->name, name, &code->loc);
switch (list) switch (list)
{ {
...@@ -839,8 +856,8 @@ resolve_omp_clauses (gfc_code *code) ...@@ -839,8 +856,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_EQV: case OMP_LIST_EQV:
case OMP_LIST_NEQV: case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL) if (n->sym->ts.type != BT_LOGICAL)
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL" gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
" at %L", "at %L",
list == OMP_LIST_AND ? ".AND." list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR." : list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.", : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
...@@ -850,8 +867,8 @@ resolve_omp_clauses (gfc_code *code) ...@@ -850,8 +867,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_MIN: case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL) && n->sym->ts.type != BT_REAL)
gfc_error ("%s REDUCTION variable '%s' must be" gfc_error ("%s REDUCTION variable '%s' must be "
" INTEGER or REAL at %L", "INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN", list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, &code->loc); n->sym->name, &code->loc);
break; break;
...@@ -859,8 +876,8 @@ resolve_omp_clauses (gfc_code *code) ...@@ -859,8 +876,8 @@ resolve_omp_clauses (gfc_code *code)
case OMP_LIST_IOR: case OMP_LIST_IOR:
case OMP_LIST_IEOR: case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER) if (n->sym->ts.type != BT_INTEGER)
gfc_error ("%s REDUCTION variable '%s' must be INTEGER" gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
" at %L", "at %L",
list == OMP_LIST_IAND ? "IAND" list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR", : list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, &code->loc); n->sym->name, &code->loc);
...@@ -878,6 +895,7 @@ resolve_omp_clauses (gfc_code *code) ...@@ -878,6 +895,7 @@ resolve_omp_clauses (gfc_code *code)
} }
} }
/* Return true if SYM is ever referenced in EXPR except in the SE node. */ /* Return true if SYM is ever referenced in EXPR except in the SE node. */
static bool static bool
...@@ -917,6 +935,7 @@ expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) ...@@ -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 EXPR is a conversion function that widens the type
if WIDENING is true or narrows the type if WIDENING is false, if WIDENING is true or narrows the type if WIDENING is false,
return the inner expression, otherwise return NULL. */ return the inner expression, otherwise return NULL. */
...@@ -950,6 +969,7 @@ is_conversion (gfc_expr *expr, bool widening) ...@@ -950,6 +969,7 @@ is_conversion (gfc_expr *expr, bool widening)
return NULL; return NULL;
} }
static void static void
resolve_omp_atomic (gfc_code *code) resolve_omp_atomic (gfc_code *code)
{ {
...@@ -968,8 +988,8 @@ 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_COMPLEX
&& code->expr->ts.type != BT_LOGICAL)) && code->expr->ts.type != BT_LOGICAL))
{ {
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of" gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
" intrinsic type at %L", &code->loc); "intrinsic type at %L", &code->loc);
return; return;
} }
...@@ -1008,8 +1028,8 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1008,8 +1028,8 @@ resolve_omp_atomic (gfc_code *code)
alt_op = INTRINSIC_EQV; alt_op = INTRINSIC_EQV;
break; break;
default: default:
gfc_error ("!$OMP ATOMIC assignment operator must be" gfc_error ("!$OMP ATOMIC assignment operator must be "
" +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where); &expr2->where);
return; return;
} }
...@@ -1056,8 +1076,8 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1056,8 +1076,8 @@ resolve_omp_atomic (gfc_code *code)
if (v == NULL) if (v == NULL)
{ {
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr" gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
" or var = expr op var at %L", &expr2->where); "or var = expr op var at %L", &expr2->where);
return; return;
} }
...@@ -1070,9 +1090,9 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1070,9 +1090,9 @@ resolve_omp_atomic (gfc_code *code)
case INTRINSIC_DIVIDE: case INTRINSIC_DIVIDE:
case INTRINSIC_EQV: case INTRINSIC_EQV:
case INTRINSIC_NEQV: case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not" gfc_error ("!$OMP ATOMIC var = var op expr not "
" mathematically equivalent to var = var op" "mathematically equivalent to var = var op "
" (expr) at %L", &expr2->where); "(expr) at %L", &expr2->where);
break; break;
default: default:
break; break;
...@@ -1102,8 +1122,8 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1102,8 +1122,8 @@ resolve_omp_atomic (gfc_code *code)
if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
{ {
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr" gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
" must be scalar and cannot reference var at %L", "must be scalar and cannot reference var at %L",
&expr2->where); &expr2->where);
return; return;
} }
...@@ -1126,15 +1146,15 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1126,15 +1146,15 @@ resolve_omp_atomic (gfc_code *code)
case GFC_ISYM_IEOR: case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL) 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", "or IEOR must have two arguments at %L",
&expr2->where); &expr2->where);
return; return;
} }
break; break;
default: default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be" gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
" MIN, MAX, IAND, IOR or IEOR at %L", "MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where); &expr2->where);
return; return;
} }
...@@ -1149,17 +1169,17 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1149,17 +1169,17 @@ resolve_omp_atomic (gfc_code *code)
&& arg->expr->symtree->n.sym == var) && arg->expr->symtree->n.sym == var)
var_arg = arg; var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL)) else if (expr_references_sym (arg->expr, var, NULL))
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not" gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
" reference '%s' at %L", var->name, &arg->expr->where); "reference '%s' at %L", var->name, &arg->expr->where);
if (arg->expr->rank != 0) if (arg->expr->rank != 0)
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar" gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
" at %L", &arg->expr->where); "at %L", &arg->expr->where);
} }
if (var_arg == NULL) if (var_arg == NULL)
{ {
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must" gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
" be '%s' at %L", var->name, &expr2->where); "be '%s' at %L", var->name, &expr2->where);
return; return;
} }
...@@ -1176,10 +1196,11 @@ resolve_omp_atomic (gfc_code *code) ...@@ -1176,10 +1196,11 @@ resolve_omp_atomic (gfc_code *code)
} }
} }
else else
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic" gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
" on right hand side at %L", &expr2->where); "on right hand side at %L", &expr2->where);
} }
struct omp_context struct omp_context
{ {
gfc_code *code; gfc_code *code;
...@@ -1189,6 +1210,7 @@ struct omp_context ...@@ -1189,6 +1210,7 @@ struct omp_context
} *omp_current_ctx; } *omp_current_ctx;
gfc_code *omp_current_do_code; gfc_code *omp_current_do_code;
void void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) 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) ...@@ -1197,6 +1219,7 @@ gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
gfc_resolve_blocks (code->block, ns); gfc_resolve_blocks (code->block, ns);
} }
void void
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) 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) ...@@ -1225,6 +1248,7 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
pointer_set_destroy (ctx.private_iterators); pointer_set_destroy (ctx.private_iterators);
} }
/* Note a DO iterator variable. This is special in !$omp parallel /* Note a DO iterator variable. This is special in !$omp parallel
construct, where they are predetermined private. */ construct, where they are predetermined private. */
...@@ -1260,6 +1284,7 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) ...@@ -1260,6 +1284,7 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
} }
} }
static void static void
resolve_omp_do (gfc_code *code) resolve_omp_do (gfc_code *code)
{ {
...@@ -1273,8 +1298,8 @@ resolve_omp_do (gfc_code *code) ...@@ -1273,8 +1298,8 @@ resolve_omp_do (gfc_code *code)
do_code = code->block->next; do_code = code->block->next;
if (do_code->op == EXEC_DO_WHILE) if (do_code->op == EXEC_DO_WHILE)
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L", gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
&do_code->loc); "at %L", &do_code->loc);
else else
{ {
gcc_assert (do_code->op == EXEC_DO); gcc_assert (do_code->op == EXEC_DO);
...@@ -1283,22 +1308,23 @@ resolve_omp_do (gfc_code *code) ...@@ -1283,22 +1308,23 @@ resolve_omp_do (gfc_code *code)
&do_code->loc); &do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym; dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate) if (dovar->attr.threadprivate)
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L", gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
&do_code->loc); "at %L", &do_code->loc);
if (code->ext.omp_clauses) if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++) for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE) if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym) if (dovar == n->sym)
{ {
gfc_error ("!$OMP DO iteration variable present on clause" gfc_error ("!$OMP DO iteration variable present on clause "
" other than PRIVATE or LASTPRIVATE at %L", "other than PRIVATE or LASTPRIVATE at %L",
&do_code->loc); &do_code->loc);
break; break;
} }
} }
} }
/* Resolve OpenMP directive clauses and check various requirements /* Resolve OpenMP directive clauses and check various requirements
of each directive. */ of each directive. */
......
gcc/fortran/options.c
/* Parse and display command line options. /* 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. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
...@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "coretypes.h" #include "coretypes.h"
...@@ -31,7 +30,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -31,7 +30,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "options.h" #include "options.h"
#include "params.h" #include "params.h"
#include "tree-inline.h" #include "tree-inline.h"
#include "gfortran.h" #include "gfortran.h"
#include "target.h" #include "target.h"
...@@ -94,8 +92,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, ...@@ -94,8 +92,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.fpe = 0; gfc_option.fpe = 0;
/* Argument pointers cannot point to anything /* Argument pointers cannot point to anything but their argument. */
but their argument. */
flag_argument_noalias = 3; flag_argument_noalias = 3;
flag_errno_math = 0; flag_errno_math = 0;
...@@ -112,7 +109,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, ...@@ -112,7 +109,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.fshort_enums = targetm.default_short_enums (); gfc_option.fshort_enums = targetm.default_short_enums ();
/* Increase MAX_ALIASED_VOPS to account for different characteristics /* Increase MAX_ALIASED_VOPS to account for different characteristics
of fortran regarding VOPs. */ of Fortran regarding VOPs. */
MAX_ALIASED_VOPS = 50; MAX_ALIASED_VOPS = 50;
return CL_Fortran; return CL_Fortran;
...@@ -125,7 +122,6 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, ...@@ -125,7 +122,6 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
static gfc_source_form static gfc_source_form
form_from_filename (const char *filename) form_from_filename (const char *filename)
{ {
static const struct static const struct
{ {
const char *extension; const char *extension;
...@@ -223,6 +219,7 @@ gfc_post_options (const char **pfilename) ...@@ -223,6 +219,7 @@ gfc_post_options (const char **pfilename)
i = strlen (canon_source_file); i = strlen (canon_source_file);
while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i])) while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i]))
i--; i--;
if (i != 0) if (i != 0)
{ {
source_path = alloca (i + 1); source_path = alloca (i + 1);
...@@ -260,8 +257,7 @@ gfc_post_options (const char **pfilename) ...@@ -260,8 +257,7 @@ gfc_post_options (const char **pfilename)
gfc_warning_now ("'-fd-lines-as-comments' has no effect " gfc_warning_now ("'-fd-lines-as-comments' has no effect "
"in free form"); "in free form");
else if (gfc_option.flag_d_lines == 1) else if (gfc_option.flag_d_lines == 1)
gfc_warning_now ("'-fd-lines-as-code' has no effect " gfc_warning_now ("'-fd-lines-as-code' has no effect in free form");
"in free form");
} }
flag_inline_trees = 1; flag_inline_trees = 1;
...@@ -304,7 +300,6 @@ gfc_post_options (const char **pfilename) ...@@ -304,7 +300,6 @@ gfc_post_options (const char **pfilename)
static void static void
set_Wall (void) set_Wall (void)
{ {
gfc_option.warn_aliasing = 1; gfc_option.warn_aliasing = 1;
gfc_option.warn_ampersand = 1; gfc_option.warn_ampersand = 1;
gfc_option.warn_line_truncation = 1; gfc_option.warn_line_truncation = 1;
...@@ -350,12 +345,13 @@ gfc_handle_module_path_options (const char *arg) ...@@ -350,12 +345,13 @@ gfc_handle_module_path_options (const char *arg)
gfc_add_include_path (gfc_option.module_dir, true); gfc_add_include_path (gfc_option.module_dir, true);
} }
static void static void
gfc_handle_fpe_trap_option (const char *arg) gfc_handle_fpe_trap_option (const char *arg)
{ {
int result, pos = 0, n; int result, pos = 0, n;
static const char * const exception[] = { "invalid", "denormal", "zero", static const char * const exception[] = { "invalid", "denormal", "zero",
"overflow", "underflow", "overflow", "underflow",
"precision", NULL }; "precision", NULL };
static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL, static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL,
GFC_FPE_ZERO, GFC_FPE_OVERFLOW, GFC_FPE_ZERO, GFC_FPE_OVERFLOW,
...@@ -366,8 +362,10 @@ gfc_handle_fpe_trap_option (const char *arg) ...@@ -366,8 +362,10 @@ gfc_handle_fpe_trap_option (const char *arg)
{ {
while (*arg == ',') while (*arg == ',')
arg++; arg++;
while (arg[pos] && arg[pos] != ',') while (arg[pos] && arg[pos] != ',')
pos++; pos++;
result = 0; result = 0;
for (n = 0; exception[n] != NULL; n++) for (n = 0; exception[n] != NULL; n++)
{ {
...@@ -380,13 +378,15 @@ gfc_handle_fpe_trap_option (const char *arg) ...@@ -380,13 +378,15 @@ gfc_handle_fpe_trap_option (const char *arg)
break; break;
} }
} }
if (! result) if (!result)
gfc_fatal_error ("Argument to -ffpe-trap is not valid: %s", arg); gfc_fatal_error ("Argument to -ffpe-trap is not valid: %s", arg);
} }
} }
/* Handle command-line options. Returns 0 if unrecognized, 1 if /* Handle command-line options. Returns 0 if unrecognized, 1 if
recognized and handled. */ recognized and handled. */
int int
gfc_handle_option (size_t scode, const char *arg, int value) 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) ...@@ -665,7 +665,8 @@ gfc_handle_option (size_t scode, const char *arg, int value)
case OPT_fmax_subrecord_length_: case OPT_fmax_subrecord_length_:
if (value > MAX_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; gfc_option.max_subrecord_length = value;
} }
......
gcc/fortran/parse.c
/* Main parser. /* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
This file is part of GCC. This file is part of GCC.
...@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include <setjmp.h> #include <setjmp.h>
...@@ -28,9 +27,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -28,9 +27,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "match.h" #include "match.h"
#include "parse.h" #include "parse.h"
/* Current statement label. Zero means no statement label. Because /* Current statement label. Zero means no statement label. Because new_st
new_st can get wiped during statement matching, we have to keep it can get wiped during statement matching, we have to keep it separate. */
separate. */
gfc_st_label *gfc_statement_label; gfc_st_label *gfc_statement_label;
...@@ -51,7 +49,7 @@ static void reject_statement (void); ...@@ -51,7 +49,7 @@ static void reject_statement (void);
gfc_match_eos(). */ gfc_match_eos(). */
static match 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; match m;
...@@ -79,11 +77,11 @@ match_word (const char *str, match (*subr) (void), locus * old_locus) ...@@ -79,11 +77,11 @@ match_word (const char *str, match (*subr) (void), locus * old_locus)
ambiguity. */ ambiguity. */
#define match(keyword, subr, st) \ #define match(keyword, subr, st) \
do { \ do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \ if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
return st; \ return st; \
else \ else \
undo_new_statement (); \ undo_new_statement (); \
} while (0); } while (0);
static gfc_statement static gfc_statement
...@@ -322,7 +320,8 @@ decode_omp_directive (void) ...@@ -322,7 +320,8 @@ decode_omp_directive (void)
if (gfc_pure (NULL)) 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 (); gfc_error_recovery ();
return ST_NONE; return ST_NONE;
} }
...@@ -434,7 +433,7 @@ next_free (void) ...@@ -434,7 +433,7 @@ next_free (void)
{ {
gfc_match_small_literal_int (&c, &cnt); gfc_match_small_literal_int (&c, &cnt);
if (cnt > 5) if (cnt > 5)
gfc_error_now ("Too many digits in statement label at %C"); gfc_error_now ("Too many digits in statement label at %C");
if (c == 0) if (c == 0)
...@@ -457,16 +456,16 @@ next_free (void) ...@@ -457,16 +456,16 @@ next_free (void)
if (at_bol && gfc_peek_char () == ';') if (at_bol && gfc_peek_char () == ';')
{ {
gfc_error_now gfc_error_now ("Semicolon at %C needs to be preceded by "
("Semicolon at %C needs to be preceded by statement"); "statement");
gfc_next_char (); /* Eat up the semicolon. */ gfc_next_char (); /* Eat up the semicolon. */
return ST_NONE; return ST_NONE;
} }
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
{ {
gfc_warning_now gfc_warning_now ("Ignoring statement label in empty statement "
("Ignoring statement label in empty statement at %C"); "at %C");
gfc_free_st_label (gfc_statement_label); gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL; gfc_statement_label = NULL;
return ST_NONE; return ST_NONE;
...@@ -669,8 +668,7 @@ next_statement (void) ...@@ -669,8 +668,7 @@ next_statement (void)
break; break;
} }
st = st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
(gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE) if (st != ST_NONE)
break; break;
...@@ -723,21 +721,19 @@ next_statement (void) ...@@ -723,21 +721,19 @@ next_statement (void)
are detected in gfc_match_end(). */ are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ #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. */ /* Push a new state onto the stack. */
static void 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->state = new_state;
p->previous = gfc_state_stack; p->previous = gfc_state_stack;
p->sym = sym; p->sym = sym;
p->head = p->tail = NULL; p->head = p->tail = NULL;
p->do_variable = NULL; p->do_variable = NULL;
gfc_state_stack = p; gfc_state_stack = p;
} }
...@@ -747,7 +743,6 @@ push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym) ...@@ -747,7 +743,6 @@ push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
static void static void
pop_state (void) pop_state (void)
{ {
gfc_state_stack = gfc_state_stack->previous; gfc_state_stack = gfc_state_stack->previous;
} }
...@@ -770,7 +765,7 @@ gfc_find_state (gfc_compile_state state) ...@@ -770,7 +765,7 @@ gfc_find_state (gfc_compile_state state)
/* Starts a new level in the statement list. */ /* Starts a new level in the statement list. */
static gfc_code * static gfc_code *
new_level (gfc_code * q) new_level (gfc_code *q)
{ {
gfc_code *p; gfc_code *p;
...@@ -857,8 +852,8 @@ check_statement_label (gfc_statement st) ...@@ -857,8 +852,8 @@ check_statement_label (gfc_statement st)
break; break;
/* Statement labels are not restricted from appearing on a /* Statement labels are not restricted from appearing on a
particular line. However, there are plenty of situations particular line. However, there are plenty of situations
where the resulting label can't be referenced. */ where the resulting label can't be referenced. */
default: default:
type = ST_LABEL_BAD_TARGET; type = ST_LABEL_BAD_TARGET;
...@@ -1230,7 +1225,7 @@ gfc_ascii_statement (gfc_statement st) ...@@ -1230,7 +1225,7 @@ gfc_ascii_statement (gfc_statement st)
/* Create a symbol for the main program and assign it to ns->proc_name. */ /* Create a symbol for the main program and assign it to ns->proc_name. */
static void static void
main_program_symbol (gfc_namespace * ns) main_program_symbol (gfc_namespace *ns)
{ {
gfc_symbol *main_program; gfc_symbol *main_program;
symbol_attribute attr; symbol_attribute attr;
...@@ -1254,7 +1249,6 @@ main_program_symbol (gfc_namespace * ns) ...@@ -1254,7 +1249,6 @@ main_program_symbol (gfc_namespace * ns)
static void static void
accept_statement (gfc_statement st) accept_statement (gfc_statement st)
{ {
switch (st) switch (st)
{ {
case ST_USE: case ST_USE:
...@@ -1275,8 +1269,8 @@ accept_statement (gfc_statement st) ...@@ -1275,8 +1269,8 @@ accept_statement (gfc_statement st)
break; break;
/* If the statement is the end of a block, lay down a special code /* 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 that allows a branch to the end of the block from within the
construct. */ construct. */
case ST_ENDIF: case ST_ENDIF:
case ST_END_SELECT: case ST_END_SELECT:
...@@ -1289,8 +1283,8 @@ accept_statement (gfc_statement st) ...@@ -1289,8 +1283,8 @@ accept_statement (gfc_statement st)
break; break;
/* The end-of-program unit statements do not get the special /* The end-of-program unit statements do not get the special
marker and require a statement of some sort if they are a marker and require a statement of some sort if they are a
branch target. */ branch target. */
case ST_END_PROGRAM: case ST_END_PROGRAM:
case ST_END_FUNCTION: case ST_END_FUNCTION:
...@@ -1338,7 +1332,6 @@ reject_statement (void) ...@@ -1338,7 +1332,6 @@ reject_statement (void)
static void static void
unexpected_statement (gfc_statement st) unexpected_statement (gfc_statement st)
{ {
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
reject_statement (); reject_statement ();
...@@ -1354,30 +1347,30 @@ unexpected_statement (gfc_statement st) ...@@ -1354,30 +1347,30 @@ unexpected_statement (gfc_statement st)
valid before calling here, ie ENTRY statements are not allowed in valid before calling here, ie ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard: INTERFACE blocks. The following diagram is taken from the standard:
+---------------------------------------+ +---------------------------------------+
| program subroutine function module | | program subroutine function module |
+---------------------------------------+ +---------------------------------------+
| use | | use |
+---------------------------------------+ +---------------------------------------+
| import | | import |
+---------------------------------------+ +---------------------------------------+
| | implicit none | | | implicit none |
| +-----------+------------------+ | +-----------+------------------+
| | parameter | implicit | | | parameter | implicit |
| +-----------+------------------+ | +-----------+------------------+
| format | | derived type | | format | | derived type |
| entry | parameter | interface | | entry | parameter | interface |
| | data | specification | | | data | specification |
| | | statement func | | | | statement func |
| +-----------+------------------+ | +-----------+------------------+
| | data | executable | | | data | executable |
+--------+-----------+------------------+ +--------+-----------+------------------+
| contains | | contains |
+---------------------------------------+ +---------------------------------------+
| internal module/subprogram | | internal module/subprogram |
+---------------------------------------+ +---------------------------------------+
| end | | end |
+---------------------------------------+ +---------------------------------------+
*/ */
...@@ -1394,7 +1387,7 @@ typedef struct ...@@ -1394,7 +1387,7 @@ typedef struct
st_state; st_state;
static try static try
verify_st_order (st_state * p, gfc_statement st) verify_st_order (st_state *p, gfc_statement st)
{ {
switch (st) switch (st)
...@@ -1419,10 +1412,10 @@ verify_st_order (st_state * p, gfc_statement st) ...@@ -1419,10 +1412,10 @@ verify_st_order (st_state * p, gfc_statement st)
if (p->state > ORDER_IMPLICIT_NONE) if (p->state > ORDER_IMPLICIT_NONE)
goto order; goto order;
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
statement disqualifies a USE but not an IMPLICIT NONE. statement disqualifies a USE but not an IMPLICIT NONE.
Duplicate IMPLICIT NONEs are caught when the implicit types Duplicate IMPLICIT NONEs are caught when the implicit types
are set. */ are set. */
p->state = ORDER_IMPLICIT_NONE; p->state = ORDER_IMPLICIT_NONE;
break; break;
...@@ -1468,9 +1461,8 @@ verify_st_order (st_state * p, gfc_statement st) ...@@ -1468,9 +1461,8 @@ verify_st_order (st_state * p, gfc_statement st)
break; break;
default: default:
gfc_internal_error gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
("Unexpected %s statement in verify_st_order() at %C", gfc_ascii_statement (st));
gfc_ascii_statement (st));
} }
/* All is well, record the statement in case we need it next time. */ /* All is well, record the statement in case we need it next time. */
...@@ -1560,8 +1552,8 @@ parse_derived (void) ...@@ -1560,8 +1552,8 @@ parse_derived (void)
case ST_PRIVATE: case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE) if (gfc_find_state (COMP_MODULE) == FAILURE)
{ {
gfc_error gfc_error ("PRIVATE statement in TYPE at %C must be inside "
("PRIVATE statement in TYPE at %C must be inside a MODULE"); "a MODULE");
error_flag = 1; error_flag = 1;
break; break;
} }
...@@ -1619,8 +1611,8 @@ parse_derived (void) ...@@ -1619,8 +1611,8 @@ parse_derived (void)
sym = gfc_current_block (); sym = gfc_current_block ();
for (c = sym->components; c; c = c->next) for (c = sym->components; c; c = c->next)
{ {
if (c->allocatable || (c->ts.type == BT_DERIVED if (c->allocatable
&& c->ts.derived->attr.alloc_comp)) || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
{ {
sym->attr.alloc_comp = 1; sym->attr.alloc_comp = 1;
break; break;
...@@ -1631,7 +1623,6 @@ parse_derived (void) ...@@ -1631,7 +1623,6 @@ parse_derived (void)
} }
/* Parse an ENUM. */ /* Parse an ENUM. */
static void static void
...@@ -1653,35 +1644,36 @@ parse_enum (void) ...@@ -1653,35 +1644,36 @@ parse_enum (void)
{ {
st = next_statement (); st = next_statement ();
switch (st) switch (st)
{ {
case ST_NONE: case ST_NONE:
unexpected_eof (); unexpected_eof ();
break; break;
case ST_ENUMERATOR: case ST_ENUMERATOR:
seen_enumerator = 1; seen_enumerator = 1;
accept_statement (st); accept_statement (st);
break; break;
case ST_END_ENUM: case ST_END_ENUM:
compiling_enum = 0; compiling_enum = 0;
if (!seen_enumerator) if (!seen_enumerator)
{ {
gfc_error ("ENUM declaration at %C has no ENUMERATORS"); gfc_error ("ENUM declaration at %C has no ENUMERATORS");
error_flag = 1; error_flag = 1;
} }
accept_statement (st); accept_statement (st);
break; break;
default: default:
gfc_free_enum_history (); gfc_free_enum_history ();
unexpected_statement (st); unexpected_statement (st);
break; break;
} }
} }
pop_state (); pop_state ();
} }
/* Parse an interface. We must be able to deal with the possibility /* Parse an interface. We must be able to deal with the possibility
of recursive interfaces. The parse_spec() subroutine is mutually of recursive interfaces. The parse_spec() subroutine is mutually
recursive with parse_interface(). */ recursive with parse_interface(). */
...@@ -1704,7 +1696,8 @@ parse_interface (void) ...@@ -1704,7 +1696,8 @@ parse_interface (void)
save = current_interface; save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC 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); push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE; current_state = COMP_NONE;
...@@ -1768,14 +1761,12 @@ loop: ...@@ -1768,14 +1761,12 @@ loop:
if (new_state != current_state) if (new_state != current_state)
{ {
if (new_state == COMP_SUBROUTINE) if (new_state == COMP_SUBROUTINE)
gfc_error gfc_error ("SUBROUTINE at %C does not belong in a "
("SUBROUTINE at %C does not belong in a generic function " "generic function interface");
"interface");
if (new_state == COMP_FUNCTION) if (new_state == COMP_FUNCTION)
gfc_error gfc_error ("FUNCTION at %C does not belong in a "
("FUNCTION at %C does not belong in a generic subroutine " "generic subroutine interface");
"interface");
} }
} }
} }
...@@ -1945,7 +1936,7 @@ parse_where_block (void) ...@@ -1945,7 +1936,7 @@ parse_where_block (void)
case ST_WHERE_BLOCK: case ST_WHERE_BLOCK:
parse_where_block (); parse_where_block ();
break; break;
case ST_ASSIGNMENT: case ST_ASSIGNMENT:
case ST_WHERE: case ST_WHERE:
...@@ -1955,9 +1946,8 @@ parse_where_block (void) ...@@ -1955,9 +1946,8 @@ parse_where_block (void)
case ST_ELSEWHERE: case ST_ELSEWHERE:
if (seen_empty_else) if (seen_empty_else)
{ {
gfc_error gfc_error ("ELSEWHERE statement at %C follows previous "
("ELSEWHERE statement at %C follows previous unmasked " "unmasked ELSEWHERE");
"ELSEWHERE");
break; break;
} }
...@@ -1982,7 +1972,6 @@ parse_where_block (void) ...@@ -1982,7 +1972,6 @@ parse_where_block (void)
reject_statement (); reject_statement ();
break; break;
} }
} }
while (st != ST_END_WHERE); while (st != ST_END_WHERE);
...@@ -2088,9 +2077,8 @@ parse_if_block (void) ...@@ -2088,9 +2077,8 @@ parse_if_block (void)
case ST_ELSEIF: case ST_ELSEIF:
if (seen_else) if (seen_else)
{ {
gfc_error gfc_error ("ELSE IF statement at %C cannot follow ELSE "
("ELSE IF statement at %C cannot follow ELSE statement at %L", "statement at %L", &else_locus);
&else_locus);
reject_statement (); reject_statement ();
break; break;
...@@ -2168,9 +2156,8 @@ parse_select_block (void) ...@@ -2168,9 +2156,8 @@ parse_select_block (void)
if (st == ST_CASE) if (st == ST_CASE)
break; break;
gfc_error gfc_error ("Expected a CASE or END SELECT statement following SELECT "
("Expected a CASE or END SELECT statement following SELECT CASE " "CASE at %C");
"at %C");
reject_statement (); reject_statement ();
} }
...@@ -2200,8 +2187,8 @@ parse_select_block (void) ...@@ -2200,8 +2187,8 @@ parse_select_block (void)
case ST_END_SELECT: case ST_END_SELECT:
break; break;
/* Can't have an executable statement because of /* Can't have an executable statement because of
parse_executable(). */ parse_executable(). */
default: default:
unexpected_statement (st); unexpected_statement (st);
break; break;
...@@ -2261,8 +2248,7 @@ check_do_closure (void) ...@@ -2261,8 +2248,7 @@ check_do_closure (void)
if (p == gfc_state_stack) if (p == gfc_state_stack)
return 1; return 1;
gfc_error gfc_error ("End of nonblock DO statement at %C is within another block");
("End of nonblock DO statement at %C is within another block");
return 2; return 2;
} }
...@@ -2320,8 +2306,8 @@ loop: ...@@ -2320,8 +2306,8 @@ loop:
case ST_ENDDO: case ST_ENDDO:
if (s.ext.end_do_label != NULL if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label) && s.ext.end_do_label != gfc_statement_label)
gfc_error_now gfc_error_now ("Statement label in ENDDO at %C doesn't match "
("Statement label in ENDDO at %C doesn't match DO label"); "DO label");
if (gfc_statement_label != NULL) if (gfc_statement_label != NULL)
{ {
...@@ -2336,9 +2322,8 @@ loop: ...@@ -2336,9 +2322,8 @@ loop:
name, but in that case we must have seen ST_ENDDO first). name, but in that case we must have seen ST_ENDDO first).
We only complain about this in pedantic mode. */ We only complain about this in pedantic mode. */
if (gfc_current_block () != NULL) if (gfc_current_block () != NULL)
gfc_error_now gfc_error_now ("named block DO at %L requires matching ENDDO name",
("named block DO at %L requires matching ENDDO name", &gfc_current_block()->declared_at);
&gfc_current_block()->declared_at);
break; break;
...@@ -2387,12 +2372,12 @@ parse_omp_do (gfc_statement omp_st) ...@@ -2387,12 +2372,12 @@ parse_omp_do (gfc_statement omp_st)
&& gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
{ {
/* In /* In
DO 100 I=1,10 DO 100 I=1,10
!$OMP DO !$OMP DO
DO J=1,10 DO J=1,10
... ...
100 CONTINUE 100 CONTINUE
there should be no !$OMP END DO. */ there should be no !$OMP END DO. */
pop_state (); pop_state ();
return ST_IMPLIED_ENDDO; return ST_IMPLIED_ENDDO;
} }
...@@ -2593,8 +2578,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) ...@@ -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)) if (((cp->ext.omp_name == NULL) ^ (new_st.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)) && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
gfc_error ("Name after !$omp critical and !$omp end critical does" gfc_error ("Name after !$omp critical and !$omp end critical does "
" not match at %C"); "not match at %C");
gfc_free ((char *) new_st.ext.omp_name); gfc_free ((char *) new_st.ext.omp_name);
break; break;
case EXEC_OMP_END_SINGLE: case EXEC_OMP_END_SINGLE:
...@@ -2649,9 +2634,8 @@ parse_executable (gfc_statement st) ...@@ -2649,9 +2634,8 @@ parse_executable (gfc_statement st)
case ST_FORALL: case ST_FORALL:
case ST_WHERE: case ST_WHERE:
case ST_SELECT_CASE: case ST_SELECT_CASE:
gfc_error gfc_error ("%s statement at %C cannot terminate a non-block "
("%s statement at %C cannot terminate a non-block DO loop", "DO loop", gfc_ascii_statement (st));
gfc_ascii_statement (st));
break; break;
default: default:
...@@ -2738,7 +2722,7 @@ static void parse_progunit (gfc_statement); ...@@ -2738,7 +2722,7 @@ static void parse_progunit (gfc_statement);
the child namespace as the parser didn't know about this procedure. */ the child namespace as the parser didn't know about this procedure. */
static void 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_namespace *ns;
gfc_symtree *st; gfc_symtree *st;
...@@ -2756,17 +2740,17 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) ...@@ -2756,17 +2740,17 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
if ((old_sym->attr.flavor == FL_PROCEDURE if ((old_sym->attr.flavor == FL_PROCEDURE
|| old_sym->ts.type == BT_UNKNOWN) || old_sym->ts.type == BT_UNKNOWN)
&& old_sym->ns == ns && old_sym->ns == ns
&& ! old_sym->attr.contained) && !old_sym->attr.contained)
{ {
/* Replace it with the symbol from the parent namespace. */ /* Replace it with the symbol from the parent namespace. */
st->n.sym = sym; st->n.sym = sym;
sym->refs++; sym->refs++;
/* Free the old (local) symbol. */ /* Free the old (local) symbol. */
old_sym->refs--; old_sym->refs--;
if (old_sym->refs == 0) if (old_sym->refs == 0)
gfc_free_symbol (old_sym); gfc_free_symbol (old_sym);
} }
/* Do the same for any contained procedures. */ /* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained); gfc_fixup_sibling_symbols (sym, ns->contained);
...@@ -2815,9 +2799,8 @@ parse_contained (int module) ...@@ -2815,9 +2799,8 @@ parse_contained (int module)
if (!module) if (!module)
{ {
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
gfc_error gfc_error ("Contained procedure '%s' at %C is already "
("Contained procedure '%s' at %C is already ambiguous", "ambiguous", gfc_new_block->name);
gfc_new_block->name);
else else
{ {
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name, if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
...@@ -2835,18 +2818,18 @@ parse_contained (int module) ...@@ -2835,18 +2818,18 @@ parse_contained (int module)
gfc_commit_symbols (); gfc_commit_symbols ();
} }
else else
sym = gfc_new_block; sym = gfc_new_block;
/* Mark this as a contained function, so it isn't replaced /* Mark this as a contained function, so it isn't replaced
by other module functions. */ by other module functions. */
sym->attr.contained = 1; sym->attr.contained = 1;
sym->attr.referenced = 1; sym->attr.referenced = 1;
parse_progunit (ST_NONE); parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */ /* Fix up any sibling functions that refer to this one. */
gfc_fixup_sibling_symbols (sym, gfc_current_ns); gfc_fixup_sibling_symbols (sym, gfc_current_ns);
/* Or refer to any of its alternate entry points. */ /* Or refer to any of its alternate entry points. */
for (el = gfc_current_ns->entries; el; el = el->next) for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
...@@ -2857,8 +2840,7 @@ parse_contained (int module) ...@@ -2857,8 +2840,7 @@ parse_contained (int module)
pop_state (); pop_state ();
break; break;
/* These statements are associated with the end of the host /* These statements are associated with the end of the host unit. */
unit. */
case ST_END_FUNCTION: case ST_END_FUNCTION:
case ST_END_MODULE: case ST_END_MODULE:
case ST_END_PROGRAM: case ST_END_PROGRAM:
...@@ -2888,9 +2870,8 @@ parse_contained (int module) ...@@ -2888,9 +2870,8 @@ parse_contained (int module)
pop_state (); pop_state ();
if (!contains_statements) if (!contains_statements)
/* This is valid in Fortran 2008. */ /* This is valid in Fortran 2008. */
gfc_notify_std (GFC_STD_GNU, "Extension: " gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
"CONTAINS statement without FUNCTION " "FUNCTION or SUBROUTINE statement at %C");
"or SUBROUTINE statement at %C");
} }
...@@ -3028,22 +3009,23 @@ parse_block_data (void) ...@@ -3028,22 +3009,23 @@ parse_block_data (void)
{ {
if (blank_block) if (blank_block)
gfc_error ("Blank BLOCK DATA at %C conflicts with " gfc_error ("Blank BLOCK DATA at %C conflicts with "
"prior BLOCK DATA at %L", &blank_locus); "prior BLOCK DATA at %L", &blank_locus);
else else
{ {
blank_block = 1; blank_block = 1;
blank_locus = gfc_current_locus; blank_locus = gfc_current_locus;
} }
} }
else else
{ {
s = gfc_get_gsymbol (gfc_new_block->name); 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); global_used(s, NULL);
else else
{ {
s->type = GSYM_BLOCK_DATA; s->type = GSYM_BLOCK_DATA;
s->where = gfc_current_locus; s->where = gfc_current_locus;
s->defined = 1; s->defined = 1;
} }
} }
...@@ -3115,7 +3097,8 @@ add_global_procedure (int sub) ...@@ -3115,7 +3097,8 @@ add_global_procedure (int sub)
s = gfc_get_gsymbol(gfc_new_block->name); s = gfc_get_gsymbol(gfc_new_block->name);
if (s->defined 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); global_used(s, NULL);
else else
{ {
...@@ -3237,7 +3220,7 @@ loop: ...@@ -3237,7 +3220,7 @@ loop:
prog_locus = gfc_current_locus; prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block); push_state (&s, COMP_PROGRAM, gfc_new_block);
main_program_symbol(gfc_current_ns); main_program_symbol (gfc_current_ns);
parse_progunit (st); parse_progunit (st);
break; break;
} }
......
gcc/fortran/primary.c
/* Primary expression subroutines /* Primary expression subroutines
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
...@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free ...@@ -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 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */ 02110-1301, USA. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "flags.h" #include "flags.h"
...@@ -179,7 +178,7 @@ match_digits (int signflag, int radix, char *buffer) ...@@ -179,7 +178,7 @@ match_digits (int signflag, int radix, char *buffer)
A sign will be accepted if signflag is set. */ A sign will be accepted if signflag is set. */
static match static match
match_integer_constant (gfc_expr ** result, int signflag) match_integer_constant (gfc_expr **result, int signflag)
{ {
int length, kind; int length, kind;
locus old_loc; locus old_loc;
...@@ -231,12 +230,12 @@ match_integer_constant (gfc_expr ** result, int signflag) ...@@ -231,12 +230,12 @@ match_integer_constant (gfc_expr ** result, int signflag)
/* Match a Hollerith constant. */ /* Match a Hollerith constant. */
static match static match
match_hollerith_constant (gfc_expr ** result) match_hollerith_constant (gfc_expr **result)
{ {
locus old_loc; locus old_loc;
gfc_expr * e = NULL; gfc_expr *e = NULL;
const char * msg; const char *msg;
char * buffer; char *buffer;
int num; int num;
int i; int i;
...@@ -244,11 +243,10 @@ match_hollerith_constant (gfc_expr ** result) ...@@ -244,11 +243,10 @@ match_hollerith_constant (gfc_expr ** result)
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
if (match_integer_constant (&e, 0) == MATCH_YES 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, if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
"Extension: Hollerith constant at %C") "at %C") == FAILURE)
== FAILURE)
goto cleanup; goto cleanup;
msg = gfc_extract_int (e, &num); msg = gfc_extract_int (e, &num);
...@@ -259,14 +257,14 @@ match_hollerith_constant (gfc_expr ** result) ...@@ -259,14 +257,14 @@ match_hollerith_constant (gfc_expr ** result)
} }
if (num == 0) if (num == 0)
{ {
gfc_error ("Invalid Hollerith constant: %L must contain at least one " gfc_error ("Invalid Hollerith constant: %L must contain at least "
"character", &old_loc); "one character", &old_loc);
goto cleanup; goto cleanup;
} }
if (e->ts.kind != gfc_default_integer_kind) if (e->ts.kind != gfc_default_integer_kind)
{ {
gfc_error ("Invalid Hollerith constant: Integer kind at %L " gfc_error ("Invalid Hollerith constant: Integer kind at %L "
"should be default", &old_loc); "should be default", &old_loc);
goto cleanup; goto cleanup;
} }
else else
...@@ -277,9 +275,9 @@ match_hollerith_constant (gfc_expr ** result) ...@@ -277,9 +275,9 @@ match_hollerith_constant (gfc_expr ** result)
buffer[i] = gfc_next_char_literal (1); buffer[i] = gfc_next_char_literal (1);
} }
gfc_free_expr (e); gfc_free_expr (e);
e = gfc_constant_result (BT_HOLLERITH, e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
gfc_default_character_kind, &gfc_current_locus); &gfc_current_locus);
e->value.character.string = gfc_getmem (num+1); e->value.character.string = gfc_getmem (num + 1);
memcpy (e->value.character.string, buffer, num); memcpy (e->value.character.string, buffer, num);
e->value.character.string[num] = '\0'; e->value.character.string[num] = '\0';
e->value.character.length = num; e->value.character.length = num;
...@@ -305,7 +303,7 @@ cleanup: ...@@ -305,7 +303,7 @@ cleanup:
and 'a1...'z. An additional extension is the use of x for z. */ and 'a1...'z. An additional extension is the use of x for z. */
static match static match
match_boz_constant (gfc_expr ** result) match_boz_constant (gfc_expr **result)
{ {
int post, radix, delim, length, x_hex, kind; int post, radix, delim, length, x_hex, kind;
locus old_loc, start_loc; locus old_loc, start_loc;
...@@ -435,7 +433,7 @@ backup: ...@@ -435,7 +433,7 @@ backup:
is nonzero. Allow integer constants if allow_int is true. */ is nonzero. Allow integer constants if allow_int is true. */
static match 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; int kind, c, count, seen_dp, seen_digits, exp_char;
locus old_loc, temp_loc; locus old_loc, temp_loc;
...@@ -472,7 +470,8 @@ match_real_constant (gfc_expr ** result, int signflag) ...@@ -472,7 +470,8 @@ match_real_constant (gfc_expr ** result, int signflag)
if (seen_dp) if (seen_dp)
goto done; 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; temp_loc = gfc_current_locus;
c = gfc_next_char (); c = gfc_next_char ();
...@@ -500,8 +499,7 @@ match_real_constant (gfc_expr ** result, int signflag) ...@@ -500,8 +499,7 @@ match_real_constant (gfc_expr ** result, int signflag)
break; break;
} }
if (!seen_digits if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
|| (c != 'e' && c != 'd' && c != 'q'))
goto done; goto done;
exp_char = c; exp_char = c;
...@@ -573,8 +571,8 @@ done: ...@@ -573,8 +571,8 @@ done:
case 'd': case 'd':
if (kind != -2) if (kind != -2)
{ {
gfc_error gfc_error ("Real number at %C has a 'd' exponent and an explicit "
("Real number at %C has a 'd' exponent and an explicit kind"); "kind");
goto cleanup; goto cleanup;
} }
kind = gfc_default_double_kind; kind = gfc_default_double_kind;
...@@ -605,7 +603,7 @@ done: ...@@ -605,7 +603,7 @@ done:
case ARITH_UNDERFLOW: case ARITH_UNDERFLOW:
if (gfc_option.warn_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); mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break; break;
...@@ -625,7 +623,7 @@ cleanup: ...@@ -625,7 +623,7 @@ cleanup:
/* Match a substring reference. */ /* Match a substring reference. */
static match 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; gfc_expr *start, *end;
locus old_loc; locus old_loc;
...@@ -848,7 +846,7 @@ match_charkind_name (char *name) ...@@ -848,7 +846,7 @@ match_charkind_name (char *name)
delimiter. Using match_kind_param() generates errors too quickly. */ delimiter. Using match_kind_param() generates errors too quickly. */
static match static match
match_string_constant (gfc_expr ** result) match_string_constant (gfc_expr **result)
{ {
char *p, name[GFC_MAX_SYMBOL_LEN + 1]; char *p, name[GFC_MAX_SYMBOL_LEN + 1];
int i, c, kind, length, delimiter; int i, c, kind, length, delimiter;
...@@ -1002,7 +1000,7 @@ no_match: ...@@ -1002,7 +1000,7 @@ no_match:
/* Match a .true. or .false. */ /* Match a .true. or .false. */
static match static match
match_logical_constant (gfc_expr ** result) match_logical_constant (gfc_expr **result)
{ {
static mstring logical_ops[] = { static mstring logical_ops[] = {
minit (".false.", 0), minit (".false.", 0),
...@@ -1043,7 +1041,7 @@ match_logical_constant (gfc_expr ** result) ...@@ -1043,7 +1041,7 @@ match_logical_constant (gfc_expr ** result)
symbolic constant. */ symbolic constant. */
static match static match
match_sym_complex_part (gfc_expr ** result) match_sym_complex_part (gfc_expr **result)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym; gfc_symbol *sym;
...@@ -1101,7 +1099,7 @@ match_sym_complex_part (gfc_expr ** result) ...@@ -1101,7 +1099,7 @@ match_sym_complex_part (gfc_expr ** result)
gfc_internal_error ("gfc_match_sym_complex_part(): Bad type"); 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; return MATCH_YES;
error: error:
...@@ -1113,7 +1111,7 @@ error: ...@@ -1113,7 +1111,7 @@ error:
/* Match a real or imaginary part of a complex number. */ /* Match a real or imaginary part of a complex number. */
static match static match
match_complex_part (gfc_expr ** result) match_complex_part (gfc_expr **result)
{ {
match m; match m;
...@@ -1132,7 +1130,7 @@ match_complex_part (gfc_expr ** result) ...@@ -1132,7 +1130,7 @@ match_complex_part (gfc_expr ** result)
/* Try to match a complex constant. */ /* Try to match a complex constant. */
static match static match
match_complex_constant (gfc_expr ** result) match_complex_constant (gfc_expr **result)
{ {
gfc_expr *e, *real, *imag; gfc_expr *e, *real, *imag;
gfc_error_buf old_error; gfc_error_buf old_error;
...@@ -1249,7 +1247,7 @@ cleanup: ...@@ -1249,7 +1247,7 @@ cleanup:
match, zero for no match. */ match, zero for no match. */
match match
gfc_match_literal_constant (gfc_expr ** result, int signflag) gfc_match_literal_constant (gfc_expr **result, int signflag)
{ {
match m; match m;
...@@ -1293,7 +1291,7 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag) ...@@ -1293,7 +1291,7 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag)
fixing things later during resolution. */ fixing things later during resolution. */
static match static match
match_actual_arg (gfc_expr ** result) match_actual_arg (gfc_expr **result)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *symtree; gfc_symtree *symtree;
...@@ -1325,18 +1323,18 @@ match_actual_arg (gfc_expr ** result) ...@@ -1325,18 +1323,18 @@ match_actual_arg (gfc_expr ** result)
/* Handle error elsewhere. */ /* Handle error elsewhere. */
/* Eliminate a couple of common cases where we know we don't /* Eliminate a couple of common cases where we know we don't
have a function argument. */ have a function argument. */
if (symtree == NULL) if (symtree == NULL)
{ {
gfc_get_sym_tree (name, NULL, &symtree); gfc_get_sym_tree (name, NULL, &symtree);
gfc_set_sym_referenced (symtree->n.sym); gfc_set_sym_referenced (symtree->n.sym);
} }
else else
{ {
gfc_symbol *sym; gfc_symbol *sym;
sym = symtree->n.sym; sym = symtree->n.sym;
gfc_set_sym_referenced (sym); gfc_set_sym_referenced (sym);
if (sym->attr.flavor != FL_PROCEDURE if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN) && sym->attr.flavor != FL_UNKNOWN)
break; break;
...@@ -1384,7 +1382,7 @@ match_actual_arg (gfc_expr ** result) ...@@ -1384,7 +1382,7 @@ match_actual_arg (gfc_expr ** result)
/* Match a keyword argument. */ /* Match a keyword argument. */
static match 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]; char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a; gfc_actual_arglist *a;
...@@ -1413,9 +1411,8 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) ...@@ -1413,9 +1411,8 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
for (a = base; a; a = a->next) for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0) if (a->name != NULL && strcmp (a->name, name) == 0)
{ {
gfc_error gfc_error ("Keyword '%s' at %C has already appeared in the "
("Keyword '%s' at %C has already appeared in the current " "current argument list", name);
"argument list", name);
return MATCH_ERROR; return MATCH_ERROR;
} }
} }
...@@ -1455,19 +1452,19 @@ match_arg_list_function (gfc_actual_arglist *result) ...@@ -1455,19 +1452,19 @@ match_arg_list_function (gfc_actual_arglist *result)
switch (name[0]) switch (name[0])
{ {
case 'l': case 'l':
if (strncmp(name, "loc", 3) == 0) if (strncmp (name, "loc", 3) == 0)
{ {
result->name = "%LOC"; result->name = "%LOC";
break; break;
} }
case 'r': case 'r':
if (strncmp(name, "ref", 3) == 0) if (strncmp (name, "ref", 3) == 0)
{ {
result->name = "%REF"; result->name = "%REF";
break; break;
} }
case 'v': case 'v':
if (strncmp(name, "val", 3) == 0) if (strncmp (name, "val", 3) == 0)
{ {
result->name = "%VAL"; result->name = "%VAL";
break; break;
...@@ -1511,7 +1508,7 @@ cleanup: ...@@ -1511,7 +1508,7 @@ cleanup:
we're matching the argument list of a subroutine. */ we're matching the argument list of a subroutine. */
match 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; gfc_actual_arglist *head, *tail;
int seen_keyword; int seen_keyword;
...@@ -1554,7 +1551,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp) ...@@ -1554,7 +1551,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
} }
/* After the first keyword argument is seen, the following /* After the first keyword argument is seen, the following
arguments must also have keywords. */ arguments must also have keywords. */
if (seen_keyword) if (seen_keyword)
{ {
m = match_keyword_arg (tail, head); m = match_keyword_arg (tail, head);
...@@ -1563,8 +1560,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp) ...@@ -1563,8 +1560,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
goto cleanup; goto cleanup;
if (m == MATCH_NO) if (m == MATCH_NO)
{ {
gfc_error gfc_error ("Missing keyword name in actual argument list at %C");
("Missing keyword name in actual argument list at %C");
goto cleanup; goto cleanup;
} }
...@@ -1623,9 +1619,8 @@ cleanup: ...@@ -1623,9 +1619,8 @@ cleanup:
element. */ element. */
static gfc_ref * static gfc_ref *
extend_ref (gfc_expr * primary, gfc_ref * tail) extend_ref (gfc_expr *primary, gfc_ref *tail)
{ {
if (primary->ref == NULL) if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref (); primary->ref = tail = gfc_get_ref ();
else else
...@@ -1646,7 +1641,7 @@ extend_ref (gfc_expr * primary, gfc_ref * tail) ...@@ -1646,7 +1641,7 @@ extend_ref (gfc_expr * primary, gfc_ref * tail)
statement. */ statement. */
static match 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]; char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail; gfc_ref *substring, *tail;
...@@ -1656,13 +1651,11 @@ match_varspec (gfc_expr * primary, int equiv_flag) ...@@ -1656,13 +1651,11 @@ match_varspec (gfc_expr * primary, int equiv_flag)
tail = NULL; tail = NULL;
if ((equiv_flag && gfc_peek_char () == '(') if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
|| sym->attr.dimension)
{ {
/* In EQUIVALENCE, we don't know yet whether we are seeing /* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character an array, character variable or array of character
variables. We'll leave the decision till resolve variables. We'll leave the decision till resolve time. */
time. */
tail = extend_ref (primary, tail); tail = extend_ref (primary, tail);
tail->type = REF_ARRAY; tail->type = REF_ARRAY;
...@@ -1734,8 +1727,8 @@ check_substring: ...@@ -1734,8 +1727,8 @@ check_substring:
{ {
if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER) if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
{ {
gfc_set_default_type (sym, 0, sym->ns); gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts; primary->ts = sym->ts;
} }
} }
...@@ -1787,7 +1780,7 @@ check_substring: ...@@ -1787,7 +1780,7 @@ check_substring:
We can have at most one full array reference. */ We can have at most one full array reference. */
symbol_attribute 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; int dimension, pointer, allocatable, target;
symbol_attribute attr; symbol_attribute attr;
...@@ -1865,7 +1858,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts) ...@@ -1865,7 +1858,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
/* Return the attribute from a general expression. */ /* Return the attribute from a general expression. */
symbol_attribute symbol_attribute
gfc_expr_attr (gfc_expr * e) gfc_expr_attr (gfc_expr *e)
{ {
symbol_attribute attr; symbol_attribute attr;
...@@ -1882,7 +1875,7 @@ gfc_expr_attr (gfc_expr * e) ...@@ -1882,7 +1875,7 @@ gfc_expr_attr (gfc_expr * e)
attr = e->value.function.esym->result->attr; attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this /* TODO: NULL() returns pointers. May have to take care of this
here. */ here. */
break; break;
...@@ -1899,7 +1892,7 @@ gfc_expr_attr (gfc_expr * e) ...@@ -1899,7 +1892,7 @@ gfc_expr_attr (gfc_expr * e)
seen. */ seen. */
match 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_constructor *head, *tail;
gfc_component *comp; gfc_component *comp;
...@@ -1936,8 +1929,7 @@ gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result) ...@@ -1936,8 +1929,7 @@ gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
{ {
if (comp->next == NULL) if (comp->next == NULL)
{ {
gfc_error gfc_error ("Too many components in structure constructor at %C");
("Too many components in structure constructor at %C");
goto cleanup; goto cleanup;
} }
...@@ -1982,7 +1974,7 @@ cleanup: ...@@ -1982,7 +1974,7 @@ cleanup:
array reference, argument list of a function, etc. */ array reference, argument list of a function, etc. */
match match
gfc_match_rvalue (gfc_expr ** result) gfc_match_rvalue (gfc_expr **result)
{ {
gfc_actual_arglist *actual_arglist; gfc_actual_arglist *actual_arglist;
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
...@@ -2020,8 +2012,8 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2020,8 +2012,8 @@ gfc_match_rvalue (gfc_expr ** result)
/* See if this is a directly recursive function call. */ /* See if this is a directly recursive function call. */
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
if (sym->attr.recursive if (sym->attr.recursive
&& gfc_peek_char () == '(' && gfc_peek_char () == '('
&& gfc_current_ns->proc_name == sym) && gfc_current_ns->proc_name == sym)
{ {
if (!sym->attr.dimension) if (!sym->attr.dimension)
goto function0; goto function0;
...@@ -2093,7 +2085,7 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2093,7 +2085,7 @@ gfc_match_rvalue (gfc_expr ** result)
if (sym == NULL) if (sym == NULL)
m = MATCH_ERROR; m = MATCH_ERROR;
else else
m = gfc_match_structure_constructor (sym, &e); m = gfc_match_structure_constructor (sym, &e);
break; break;
/* If we're here, then the name is known to be the name of a /* 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) ...@@ -2108,9 +2100,9 @@ gfc_match_rvalue (gfc_expr ** result)
} }
/* At this point, the name has to be a non-statement function. /* At this point, the name has to be a non-statement function.
If the name is the same as the current function being If the name is the same as the current function being
compiled, then we have a variable reference (to the function compiled, then we have a variable reference (to the function
result) if the name is non-recursive. */ result) if the name is non-recursive. */
st = gfc_enclosing_unit (NULL); st = gfc_enclosing_unit (NULL);
...@@ -2176,8 +2168,8 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2176,8 +2168,8 @@ gfc_match_rvalue (gfc_expr ** result)
case FL_UNKNOWN: case FL_UNKNOWN:
/* Special case for derived type variables that get their types /* Special case for derived type variables that get their types
via an IMPLICIT statement. This can't wait for the via an IMPLICIT statement. This can't wait for the
resolution phase. */ resolution phase. */
if (gfc_peek_char () == '%' if (gfc_peek_char () == '%'
&& sym->ts.type == BT_UNKNOWN && sym->ts.type == BT_UNKNOWN
...@@ -2185,7 +2177,7 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2185,7 +2177,7 @@ gfc_match_rvalue (gfc_expr ** result)
gfc_set_default_type (sym, 0, sym->ns); gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a /* If the symbol has a dimension attribute, the expression is a
variable. */ variable. */
if (sym->attr.dimension) if (sym->attr.dimension)
{ {
...@@ -2204,8 +2196,8 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2204,8 +2196,8 @@ gfc_match_rvalue (gfc_expr ** result)
} }
/* Name is not an array, so we peek to see if a '(' implies a /* Name is not an array, so we peek to see if a '(' implies a
function call or a substring reference. Otherwise the function call or a substring reference. Otherwise the
variable is just a scalar. */ variable is just a scalar. */
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
if (gfc_peek_char () != '(') if (gfc_peek_char () != '(')
...@@ -2310,7 +2302,7 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2310,7 +2302,7 @@ gfc_match_rvalue (gfc_expr ** result)
} }
/* If our new function returns a character, array or structure /* 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); m = match_varspec (e, 0);
if (m == MATCH_NO) if (m == MATCH_NO)
...@@ -2357,7 +2349,7 @@ gfc_match_rvalue (gfc_expr ** result) ...@@ -2357,7 +2349,7 @@ gfc_match_rvalue (gfc_expr ** result)
match of the symbol to the local scope. */ match of the symbol to the local scope. */
static match 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_symbol *sym;
gfc_symtree *st; gfc_symtree *st;
...@@ -2387,10 +2379,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag) ...@@ -2387,10 +2379,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
{ {
case FL_VARIABLE: case FL_VARIABLE:
if (sym->attr.protected && sym->attr.use_assoc) if (sym->attr.protected && sym->attr.use_assoc)
{ {
gfc_error ("Assigning to PROTECTED variable at %C"); gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR; return MATCH_ERROR;
} }
break; break;
case FL_UNKNOWN: case FL_UNKNOWN:
...@@ -2464,14 +2456,16 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag) ...@@ -2464,14 +2456,16 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
return MATCH_YES; return MATCH_YES;
} }
match 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); return match_variable (result, equiv_flag, 1);
} }
match match
gfc_match_equiv_variable (gfc_expr ** result) gfc_match_equiv_variable (gfc_expr **result)
{ {
return match_variable (result, 1, 0); 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) ...@@ -113,7 +113,6 @@ gfc_scanner_done_1 (void)
gfc_free(file_head); gfc_free(file_head);
file_head = f; file_head = f;
} }
} }
...@@ -248,12 +247,12 @@ gfc_open_intrinsic_module (const char *name) ...@@ -248,12 +247,12 @@ gfc_open_intrinsic_module (const char *name)
return open_included_file (name, intrinsic_modules_dirs, true); return open_included_file (name, intrinsic_modules_dirs, true);
} }
/* Test to see if we're at the end of the main source file. */ /* Test to see if we're at the end of the main source file. */
int int
gfc_at_end (void) gfc_at_end (void)
{ {
return end_flag; return end_flag;
} }
...@@ -263,7 +262,6 @@ gfc_at_end (void) ...@@ -263,7 +262,6 @@ gfc_at_end (void)
int int
gfc_at_eof (void) gfc_at_eof (void)
{ {
if (gfc_at_end ()) if (gfc_at_end ())
return 1; return 1;
...@@ -294,7 +292,6 @@ gfc_at_bol (void) ...@@ -294,7 +292,6 @@ gfc_at_bol (void)
int int
gfc_at_eol (void) gfc_at_eol (void)
{ {
if (gfc_at_eof ()) if (gfc_at_eof ())
return 1; return 1;
...@@ -318,7 +315,7 @@ gfc_advance_line (void) ...@@ -318,7 +315,7 @@ gfc_advance_line (void)
gfc_current_locus.lb = gfc_current_locus.lb->next; 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; gfc_current_locus.nextc = gfc_current_locus.lb->line;
else else
{ {
...@@ -355,6 +352,7 @@ next_char (void) ...@@ -355,6 +352,7 @@ next_char (void)
return c; return c;
} }
/* Skip a comment. When we come here the parse pointer is positioned /* Skip a comment. When we come here the parse pointer is positioned
immediately after the comment character. If we ever implement immediately after the comment character. If we ever implement
compiler directives withing comments, here is where we parse the compiler directives withing comments, here is where we parse the
...@@ -714,10 +712,9 @@ restart: ...@@ -714,10 +712,9 @@ restart:
{ {
if (++continue_count == gfc_option.max_continue_free) if (++continue_count == gfc_option.max_continue_free)
{ {
if (gfc_notification_std (GFC_STD_GNU) if (gfc_notification_std (GFC_STD_GNU) || pedantic)
|| pedantic) gfc_warning ("Limit of %d continuations exceeded in "
gfc_warning ("Limit of %d continuations exceeded in statement at %C", "statement at %C", gfc_option.max_continue_free);
gfc_option.max_continue_free);
} }
} }
continue_line = gfc_current_locus.lb->linenum; continue_line = gfc_current_locus.lb->linenum;
...@@ -761,7 +758,8 @@ restart: ...@@ -761,7 +758,8 @@ restart:
if (in_string) if (in_string)
{ {
if (gfc_option.warn_ampersand) 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--; gfc_current_locus.nextc--;
} }
/* Both !$omp and !$ -fopenmp continuation lines have & on the /* Both !$omp and !$ -fopenmp continuation lines have & on the
...@@ -835,10 +833,10 @@ restart: ...@@ -835,10 +833,10 @@ restart:
{ {
if (++continue_count == gfc_option.max_continue_fixed) if (++continue_count == gfc_option.max_continue_fixed)
{ {
if (gfc_notification_std (GFC_STD_GNU) if (gfc_notification_std (GFC_STD_GNU) || pedantic)
|| pedantic) gfc_warning ("Limit of %d continuations exceeded in "
gfc_warning ("Limit of %d continuations exceeded in statement at %C", "statement at %C",
gfc_option.max_continue_fixed); gfc_option.max_continue_fixed);
} }
} }
...@@ -997,7 +995,7 @@ gfc_gobble_whitespace (void) ...@@ -997,7 +995,7 @@ gfc_gobble_whitespace (void)
parts of gfortran. */ parts of gfortran. */
static int 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; static int linenum = 0, current_line = 1;
int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
...@@ -1052,11 +1050,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen) ...@@ -1052,11 +1050,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& !seen_printable && seen_ampersand) && !seen_printable && seen_ampersand)
{ {
if (pedantic) if (pedantic)
gfc_error_now gfc_error_now ("'&' not allowed by itself in line %d",
("'&' not allowed by itself in line %d", current_line); current_line);
else else
gfc_warning_now gfc_warning_now ("'&' not allowed by itself in line %d",
("'&' not allowed by itself in line %d", current_line); current_line);
} }
break; break;
} }
...@@ -1084,11 +1082,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen) ...@@ -1084,11 +1082,11 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& c == '!' && !seen_printable && seen_ampersand) && c == '!' && !seen_printable && seen_ampersand)
{ {
if (pedantic) if (pedantic)
gfc_error_now ( gfc_error_now ("'&' not allowed by itself with comment in "
"'&' not allowed by itself with comment in line %d", current_line); "line %d", current_line);
else else
gfc_warning_now ( gfc_warning_now ("'&' not allowed by itself with comment in "
"'&' not allowed by itself with comment in line %d", current_line); "line %d", current_line);
seen_printable = 1; seen_printable = 1;
} }
...@@ -1103,8 +1101,8 @@ load_line (FILE * input, char **pbuf, int *pbuflen) ...@@ -1103,8 +1101,8 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
&& current_line != linenum) && current_line != linenum)
{ {
linenum = current_line; linenum = current_line;
gfc_warning_now ( gfc_warning_now ("Nonconforming tab character in column 1 "
"Nonconforming tab character in column 1 of line %d", linenum); "of line %d", linenum);
} }
while (i <= 6) while (i <= 6)
...@@ -1127,7 +1125,7 @@ load_line (FILE * input, char **pbuf, int *pbuflen) ...@@ -1127,7 +1125,7 @@ load_line (FILE * input, char **pbuf, int *pbuflen)
overlong line. */ overlong line. */
buflen = buflen * 2; buflen = buflen * 2;
*pbuf = xrealloc (*pbuf, buflen + 1); *pbuf = xrealloc (*pbuf, buflen + 1);
buffer = (*pbuf)+i; buffer = (*pbuf) + i;
} }
} }
else if (i >= maxlen) else if (i >= maxlen)
...@@ -1234,10 +1232,10 @@ preprocessor_line (char *c) ...@@ -1234,10 +1232,10 @@ preprocessor_line (char *c)
/* Make filename end at quote. */ /* Make filename end at quote. */
unescape = 0; unescape = 0;
escaped = false; escaped = false;
while (*c && ! (! escaped && *c == '"')) while (*c && ! (!escaped && *c == '"'))
{ {
if (escaped) if (escaped)
escaped = false; escaped = false;
else if (*c == '\\') else if (*c == '\\')
{ {
escaped = true; escaped = true;
...@@ -1407,6 +1405,7 @@ include_line (char *line) ...@@ -1407,6 +1405,7 @@ include_line (char *line)
return true; return true;
} }
/* Load a file into memory by calling load_line until the file ends. */ /* Load a file into memory by calling load_line until the file ends. */
static try static try
...@@ -1582,7 +1581,7 @@ unescape_filename (const char *ptr) ...@@ -1582,7 +1581,7 @@ unescape_filename (const char *ptr)
++p; ++p;
} }
if (! *p || p[1]) if (!*p || p[1])
return NULL; return NULL;
/* Undo effects of cpp_quote_string. */ /* Undo effects of cpp_quote_string. */
......
gcc/fortran/simplify.c
...@@ -93,20 +93,21 @@ static int xascii_table[256]; ...@@ -93,20 +93,21 @@ static int xascii_table[256];
node, otherwise returns &gfc_bad_expr and frees the node. */ node, otherwise returns &gfc_bad_expr and frees the node. */
static gfc_expr * static gfc_expr *
range_check (gfc_expr * result, const char *name) range_check (gfc_expr *result, const char *name)
{ {
switch (gfc_range_check (result)) switch (gfc_range_check (result))
{ {
case ARITH_OK: case ARITH_OK:
return result; return result;
case ARITH_OVERFLOW: 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; break;
case ARITH_UNDERFLOW: 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; break;
case ARITH_NAN: case ARITH_NAN:
...@@ -114,7 +115,8 @@ range_check (gfc_expr * result, const char *name) ...@@ -114,7 +115,8 @@ range_check (gfc_expr * result, const char *name)
break; break;
default: 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; break;
} }
...@@ -127,7 +129,7 @@ range_check (gfc_expr * result, const char *name) ...@@ -127,7 +129,7 @@ range_check (gfc_expr * result, const char *name)
kind parameter. Returns the kind, -1 if something went wrong. */ kind parameter. Returns the kind, -1 if something went wrong. */
static int 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; int kind;
...@@ -190,7 +192,6 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize) ...@@ -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 If the bitsize-1 bit is set, this is taken as a sign bit and
the number is converted to the corresponding negative number. */ the number is converted to the corresponding negative number. */
static void static void
convert_mpz_to_signed (mpz_t x, int bitsize) convert_mpz_to_signed (mpz_t x, int bitsize)
{ {
...@@ -206,9 +207,9 @@ 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); mpz_sub_ui (mask, mask, 1);
/* We negate the number by hand, zeroing the high bits, that is /* We negate the number by hand, zeroing the high bits, that is
make it the corresponding positive number, and then have it make it the corresponding positive number, and then have it
negated by GMP, giving the correct representation of the negated by GMP, giving the correct representation of the
negative number. */ negative number. */
mpz_com (x, x); mpz_com (x, x);
mpz_add_ui (x, x, 1); mpz_add_ui (x, x, 1);
mpz_and (x, x, mask); mpz_and (x, x, mask);
...@@ -223,7 +224,7 @@ convert_mpz_to_signed (mpz_t x, int bitsize) ...@@ -223,7 +224,7 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
/********************** Simplification functions *****************************/ /********************** Simplification functions *****************************/
gfc_expr * gfc_expr *
gfc_simplify_abs (gfc_expr * e) gfc_simplify_abs (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -267,7 +268,7 @@ gfc_simplify_abs (gfc_expr * e) ...@@ -267,7 +268,7 @@ gfc_simplify_abs (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_achar (gfc_expr * e) gfc_simplify_achar (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int index; int index;
...@@ -297,14 +298,15 @@ gfc_simplify_achar (gfc_expr * e) ...@@ -297,14 +298,15 @@ gfc_simplify_achar (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_acos (gfc_expr * x) gfc_simplify_acos (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT) if (x->expr_type != EXPR_CONSTANT)
return NULL; 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", gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where); &x->where);
...@@ -319,7 +321,7 @@ gfc_simplify_acos (gfc_expr * x) ...@@ -319,7 +321,7 @@ gfc_simplify_acos (gfc_expr * x)
} }
gfc_expr * gfc_expr *
gfc_simplify_acosh (gfc_expr * x) gfc_simplify_acosh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -341,7 +343,7 @@ gfc_simplify_acosh (gfc_expr * x) ...@@ -341,7 +343,7 @@ gfc_simplify_acosh (gfc_expr * x)
} }
gfc_expr * gfc_expr *
gfc_simplify_adjustl (gfc_expr * e) gfc_simplify_adjustl (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int count, i, len; int count, i, len;
...@@ -366,15 +368,10 @@ gfc_simplify_adjustl (gfc_expr * e) ...@@ -366,15 +368,10 @@ gfc_simplify_adjustl (gfc_expr * e)
} }
for (i = 0; i < len - count; ++i) 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) 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 */ result->value.character.string[len] = '\0'; /* For debugger */
...@@ -383,7 +380,7 @@ gfc_simplify_adjustl (gfc_expr * e) ...@@ -383,7 +380,7 @@ gfc_simplify_adjustl (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_adjustr (gfc_expr * e) gfc_simplify_adjustr (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int count, i, len; int count, i, len;
...@@ -408,15 +405,10 @@ gfc_simplify_adjustr (gfc_expr * e) ...@@ -408,15 +405,10 @@ gfc_simplify_adjustr (gfc_expr * e)
} }
for (i = 0; i < count; ++i) for (i = 0; i < count; ++i)
{ result->value.character.string[i] = ' ';
result->value.character.string[i] = ' ';
}
for (i = count; i < len; ++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 */ result->value.character.string[len] = '\0'; /* For debugger */
...@@ -425,9 +417,8 @@ gfc_simplify_adjustr (gfc_expr * e) ...@@ -425,9 +417,8 @@ gfc_simplify_adjustr (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_aimag (gfc_expr * e) gfc_simplify_aimag (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT) if (e->expr_type != EXPR_CONSTANT)
...@@ -441,7 +432,7 @@ gfc_simplify_aimag (gfc_expr * e) ...@@ -441,7 +432,7 @@ gfc_simplify_aimag (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_aint (gfc_expr * e, gfc_expr * k) gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *rtrunc, *result; gfc_expr *rtrunc, *result;
int kind; int kind;
...@@ -465,7 +456,7 @@ gfc_simplify_aint (gfc_expr * e, gfc_expr * k) ...@@ -465,7 +456,7 @@ gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_dint (gfc_expr * e) gfc_simplify_dint (gfc_expr *e)
{ {
gfc_expr *rtrunc, *result; gfc_expr *rtrunc, *result;
...@@ -484,7 +475,7 @@ gfc_simplify_dint (gfc_expr * e) ...@@ -484,7 +475,7 @@ gfc_simplify_dint (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_anint (gfc_expr * e, gfc_expr * k) gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -505,7 +496,7 @@ gfc_simplify_anint (gfc_expr * e, gfc_expr * k) ...@@ -505,7 +496,7 @@ gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_and (gfc_expr * x, gfc_expr * y) gfc_simplify_and (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -530,7 +521,7 @@ gfc_simplify_and (gfc_expr * x, gfc_expr * y) ...@@ -530,7 +521,7 @@ gfc_simplify_and (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_dnint (gfc_expr * e) gfc_simplify_dnint (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -546,14 +537,15 @@ gfc_simplify_dnint (gfc_expr * e) ...@@ -546,14 +537,15 @@ gfc_simplify_dnint (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_asin (gfc_expr * x) gfc_simplify_asin (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT) if (x->expr_type != EXPR_CONSTANT)
return NULL; 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", gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where); &x->where);
...@@ -562,14 +554,14 @@ gfc_simplify_asin (gfc_expr * x) ...@@ -562,14 +554,14 @@ gfc_simplify_asin (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); 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"); return range_check (result, "ASIN");
} }
gfc_expr * gfc_expr *
gfc_simplify_asinh (gfc_expr * x) gfc_simplify_asinh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -578,14 +570,14 @@ gfc_simplify_asinh (gfc_expr * x) ...@@ -578,14 +570,14 @@ gfc_simplify_asinh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); 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"); return range_check (result, "ASINH");
} }
gfc_expr * gfc_expr *
gfc_simplify_atan (gfc_expr * x) gfc_simplify_atan (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -594,22 +586,22 @@ gfc_simplify_atan (gfc_expr * x) ...@@ -594,22 +586,22 @@ gfc_simplify_atan (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); 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"); return range_check (result, "ATAN");
} }
gfc_expr * gfc_expr *
gfc_simplify_atanh (gfc_expr * x) gfc_simplify_atanh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT) if (x->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
if (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) || mpfr_cmp_si (x->value.real, -1) <= 0)
{ {
gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1", gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
&x->where); &x->where);
...@@ -618,14 +610,14 @@ gfc_simplify_atanh (gfc_expr * x) ...@@ -618,14 +610,14 @@ gfc_simplify_atanh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); 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"); return range_check (result, "ATANH");
} }
gfc_expr * gfc_expr *
gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x) gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -636,9 +628,8 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x) ...@@ -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) if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{ {
gfc_error gfc_error ("If first argument of ATAN2 %L is zero, then the "
("If first argument of ATAN2 %L is zero, then the second argument " "second argument must not be zero", &x->where);
"must not be zero", &x->where);
gfc_free_expr (result); gfc_free_expr (result);
return &gfc_bad_expr; return &gfc_bad_expr;
} }
...@@ -650,7 +641,7 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x) ...@@ -650,7 +641,7 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_bit_size (gfc_expr * e) gfc_simplify_bit_size (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -664,7 +655,7 @@ gfc_simplify_bit_size (gfc_expr * e) ...@@ -664,7 +655,7 @@ gfc_simplify_bit_size (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_btest (gfc_expr * e, gfc_expr * bit) gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
{ {
int b; int b;
...@@ -679,7 +670,7 @@ gfc_simplify_btest (gfc_expr * e, gfc_expr * bit) ...@@ -679,7 +670,7 @@ gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
gfc_expr * gfc_expr *
gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *ceil, *result; gfc_expr *ceil, *result;
int kind; int kind;
...@@ -696,7 +687,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) ...@@ -696,7 +687,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
ceil = gfc_copy_expr (e); ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real); 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); gfc_free_expr (ceil);
...@@ -705,7 +696,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) ...@@ -705,7 +696,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_char (gfc_expr * e, gfc_expr * k) gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *result; gfc_expr *result;
int c, kind; int c, kind;
...@@ -738,7 +729,7 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k) ...@@ -738,7 +729,7 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k)
/* Common subroutine for simplifying CMPLX and DCMPLX. */ /* Common subroutine for simplifying CMPLX and DCMPLX. */
static gfc_expr * 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; gfc_expr *result;
...@@ -787,7 +778,7 @@ simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind) ...@@ -787,7 +778,7 @@ simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
gfc_expr * 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; int kind;
...@@ -804,7 +795,7 @@ gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k) ...@@ -804,7 +795,7 @@ gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_complex (gfc_expr * x, gfc_expr * y) gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
{ {
int kind; int kind;
...@@ -832,7 +823,7 @@ gfc_simplify_complex (gfc_expr * x, gfc_expr * y) ...@@ -832,7 +823,7 @@ gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_conjg (gfc_expr * e) gfc_simplify_conjg (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -847,7 +838,7 @@ gfc_simplify_conjg (gfc_expr * e) ...@@ -847,7 +838,7 @@ gfc_simplify_conjg (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_cos (gfc_expr * x) gfc_simplify_cos (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t xp, xq; mpfr_t xp, xq;
...@@ -869,7 +860,7 @@ gfc_simplify_cos (gfc_expr * x) ...@@ -869,7 +860,7 @@ gfc_simplify_cos (gfc_expr * x)
mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE); mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_cosh (xq, x->value.complex.i, 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_sin (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE); mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
...@@ -889,7 +880,7 @@ gfc_simplify_cos (gfc_expr * x) ...@@ -889,7 +880,7 @@ gfc_simplify_cos (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_cosh (gfc_expr * x) gfc_simplify_cosh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -905,7 +896,7 @@ gfc_simplify_cosh (gfc_expr * x) ...@@ -905,7 +896,7 @@ gfc_simplify_cosh (gfc_expr * x)
gfc_expr * 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 if (x->expr_type != EXPR_CONSTANT
...@@ -917,7 +908,7 @@ gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y) ...@@ -917,7 +908,7 @@ gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_dble (gfc_expr * e) gfc_simplify_dble (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -947,7 +938,7 @@ gfc_simplify_dble (gfc_expr * e) ...@@ -947,7 +938,7 @@ gfc_simplify_dble (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_digits (gfc_expr * x) gfc_simplify_digits (gfc_expr *x)
{ {
int i, digits; int i, digits;
...@@ -972,7 +963,7 @@ gfc_simplify_digits (gfc_expr * x) ...@@ -972,7 +963,7 @@ gfc_simplify_digits (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_dim (gfc_expr * x, gfc_expr * y) gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -995,7 +986,8 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y) ...@@ -995,7 +986,8 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
case BT_REAL: case BT_REAL:
if (mpfr_cmp (x->value.real, y->value.real) > 0) 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 else
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
...@@ -1010,15 +1002,14 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y) ...@@ -1010,15 +1002,14 @@ gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
gfc_expr * 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; gfc_expr *a1, *a2, *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
result = result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
a1 = gfc_real2real (x, gfc_default_double_kind); a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, 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) ...@@ -1033,7 +1024,7 @@ gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_epsilon (gfc_expr * e) gfc_simplify_epsilon (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -1049,7 +1040,7 @@ gfc_simplify_epsilon (gfc_expr * e) ...@@ -1049,7 +1040,7 @@ gfc_simplify_epsilon (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_exp (gfc_expr * x) gfc_simplify_exp (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t xp, xq; mpfr_t xp, xq;
...@@ -1062,7 +1053,7 @@ gfc_simplify_exp (gfc_expr * x) ...@@ -1062,7 +1053,7 @@ gfc_simplify_exp (gfc_expr * x)
switch (x->ts.type) switch (x->ts.type)
{ {
case BT_REAL: 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; break;
case BT_COMPLEX: case BT_COMPLEX:
...@@ -1085,9 +1076,8 @@ gfc_simplify_exp (gfc_expr * x) ...@@ -1085,9 +1076,8 @@ gfc_simplify_exp (gfc_expr * x)
return range_check (result, "EXP"); return range_check (result, "EXP");
} }
/* FIXME: MPFR should be able to do this better */
gfc_expr * gfc_expr *
gfc_simplify_exponent (gfc_expr * x) gfc_simplify_exponent (gfc_expr *x)
{ {
int i; int i;
gfc_expr *result; gfc_expr *result;
...@@ -1114,7 +1104,7 @@ gfc_simplify_exponent (gfc_expr * x) ...@@ -1114,7 +1104,7 @@ gfc_simplify_exponent (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_float (gfc_expr * a) gfc_simplify_float (gfc_expr *a)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -1127,7 +1117,7 @@ gfc_simplify_float (gfc_expr * a) ...@@ -1127,7 +1117,7 @@ gfc_simplify_float (gfc_expr * a)
gfc_expr * gfc_expr *
gfc_simplify_floor (gfc_expr * e, gfc_expr * k) gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t floor; mpfr_t floor;
...@@ -1155,7 +1145,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k) ...@@ -1155,7 +1145,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_fraction (gfc_expr * x) gfc_simplify_fraction (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t absv, exp, pow2; mpfr_t absv, exp, pow2;
...@@ -1196,7 +1186,7 @@ gfc_simplify_fraction (gfc_expr * x) ...@@ -1196,7 +1186,7 @@ gfc_simplify_fraction (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_huge (gfc_expr * e) gfc_simplify_huge (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -1224,7 +1214,7 @@ gfc_simplify_huge (gfc_expr * e) ...@@ -1224,7 +1214,7 @@ gfc_simplify_huge (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_iachar (gfc_expr * e) gfc_simplify_iachar (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int index; int index;
...@@ -1248,7 +1238,7 @@ gfc_simplify_iachar (gfc_expr * e) ...@@ -1248,7 +1238,7 @@ gfc_simplify_iachar (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_iand (gfc_expr * x, gfc_expr * y) gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -1264,7 +1254,7 @@ gfc_simplify_iand (gfc_expr * x, gfc_expr * y) ...@@ -1264,7 +1254,7 @@ gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y) gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int k, pos; int k, pos;
...@@ -1302,7 +1292,7 @@ gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y) ...@@ -1302,7 +1292,7 @@ gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
gfc_expr * 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; gfc_expr *result;
int pos, len; int pos, len;
...@@ -1350,17 +1340,11 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z) ...@@ -1350,17 +1340,11 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
for (i = 0; i < bitsize; i++) for (i = 0; i < bitsize; i++)
{ {
if (bits[i] == 0) if (bits[i] == 0)
{ mpz_clrbit (result->value.integer, i);
mpz_clrbit (result->value.integer, i);
}
else if (bits[i] == 1) else if (bits[i] == 1)
{ mpz_setbit (result->value.integer, i);
mpz_setbit (result->value.integer, i);
}
else else
{ gfc_internal_error ("IBITS: Bad bit");
gfc_internal_error ("IBITS: Bad bit");
}
} }
gfc_free (bits); gfc_free (bits);
...@@ -1370,7 +1354,7 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z) ...@@ -1370,7 +1354,7 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
gfc_expr * gfc_expr *
gfc_simplify_ibset (gfc_expr * x, gfc_expr * y) gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int k, pos; int k, pos;
...@@ -1408,7 +1392,7 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y) ...@@ -1408,7 +1392,7 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_ichar (gfc_expr * e) gfc_simplify_ichar (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int index; int index;
...@@ -1438,7 +1422,7 @@ gfc_simplify_ichar (gfc_expr * e) ...@@ -1438,7 +1422,7 @@ gfc_simplify_ichar (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_ieor (gfc_expr * x, gfc_expr * y) gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -1454,7 +1438,7 @@ gfc_simplify_ieor (gfc_expr * x, gfc_expr * y) ...@@ -1454,7 +1438,7 @@ gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
gfc_expr * 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; gfc_expr *result;
int back, len, lensub; int back, len, lensub;
...@@ -1482,7 +1466,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1482,7 +1466,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
if (back == 0) if (back == 0)
{ {
if (lensub == 0) if (lensub == 0)
{ {
mpz_set_si (result->value.integer, 1); mpz_set_si (result->value.integer, 1);
...@@ -1494,8 +1477,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1494,8 +1477,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{ {
for (j = 0; j < lensub; j++) for (j = 0; j < lensub; j++)
{ {
if (y->value.character.string[j] == if (y->value.character.string[j]
x->value.character.string[i]) == x->value.character.string[i])
{ {
index = i + 1; index = i + 1;
goto done; goto done;
...@@ -1509,16 +1492,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1509,16 +1492,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{ {
for (j = 0; j < lensub; j++) for (j = 0; j < lensub; j++)
{ {
if (y->value.character.string[j] == if (y->value.character.string[j]
x->value.character.string[i]) == x->value.character.string[i])
{ {
start = i; start = i;
count = 0; count = 0;
for (k = 0; k < lensub; k++) for (k = 0; k < lensub; k++)
{ {
if (y->value.character.string[k] == if (y->value.character.string[k]
x->value.character.string[k + start]) == x->value.character.string[k + start])
count++; count++;
} }
...@@ -1535,7 +1518,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1535,7 +1518,6 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
} }
else else
{ {
if (lensub == 0) if (lensub == 0)
{ {
mpz_set_si (result->value.integer, len + 1); mpz_set_si (result->value.integer, len + 1);
...@@ -1547,8 +1529,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1547,8 +1529,8 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{ {
for (j = 0; j < lensub; j++) for (j = 0; j < lensub; j++)
{ {
if (y->value.character.string[j] == if (y->value.character.string[j]
x->value.character.string[len - i]) == x->value.character.string[len - i])
{ {
index = len - i + 1; index = len - i + 1;
goto done; goto done;
...@@ -1562,16 +1544,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) ...@@ -1562,16 +1544,16 @@ gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
{ {
for (j = 0; j < lensub; j++) for (j = 0; j < lensub; j++)
{ {
if (y->value.character.string[j] == if (y->value.character.string[j]
x->value.character.string[len - i]) == x->value.character.string[len - i])
{ {
start = len - i; start = len - i;
if (start <= len - lensub) if (start <= len - lensub)
{ {
count = 0; count = 0;
for (k = 0; k < lensub; k++) for (k = 0; k < lensub; k++)
if (y->value.character.string[k] == if (y->value.character.string[k]
x->value.character.string[k + start]) == x->value.character.string[k + start])
count++; count++;
if (count == lensub) if (count == lensub)
...@@ -1597,7 +1579,7 @@ done: ...@@ -1597,7 +1579,7 @@ done:
gfc_expr * 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; gfc_expr *rpart, *rtrunc, *result;
int kind; int kind;
...@@ -1644,7 +1626,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k) ...@@ -1644,7 +1626,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k)
static gfc_expr * 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; gfc_expr *rpart, *rtrunc, *result;
...@@ -1684,27 +1666,30 @@ gfc_simplify_intconv (gfc_expr * e, int kind, const char *name) ...@@ -1684,27 +1666,30 @@ gfc_simplify_intconv (gfc_expr * e, int kind, const char *name)
return range_check (result, name); return range_check (result, name);
} }
gfc_expr * gfc_expr *
gfc_simplify_int2 (gfc_expr * e) gfc_simplify_int2 (gfc_expr *e)
{ {
return gfc_simplify_intconv (e, 2, "INT2"); return gfc_simplify_intconv (e, 2, "INT2");
} }
gfc_expr * gfc_expr *
gfc_simplify_int8 (gfc_expr * e) gfc_simplify_int8 (gfc_expr *e)
{ {
return gfc_simplify_intconv (e, 8, "INT8"); return gfc_simplify_intconv (e, 8, "INT8");
} }
gfc_expr * gfc_expr *
gfc_simplify_long (gfc_expr * e) gfc_simplify_long (gfc_expr *e)
{ {
return gfc_simplify_intconv (e, 4, "LONG"); return gfc_simplify_intconv (e, 4, "LONG");
} }
gfc_expr * gfc_expr *
gfc_simplify_ifix (gfc_expr * e) gfc_simplify_ifix (gfc_expr *e)
{ {
gfc_expr *rtrunc, *result; gfc_expr *rtrunc, *result;
...@@ -1725,7 +1710,7 @@ gfc_simplify_ifix (gfc_expr * e) ...@@ -1725,7 +1710,7 @@ gfc_simplify_ifix (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_idint (gfc_expr * e) gfc_simplify_idint (gfc_expr *e)
{ {
gfc_expr *rtrunc, *result; gfc_expr *rtrunc, *result;
...@@ -1746,7 +1731,7 @@ gfc_simplify_idint (gfc_expr * e) ...@@ -1746,7 +1731,7 @@ gfc_simplify_idint (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_ior (gfc_expr * x, gfc_expr * y) gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -1761,7 +1746,7 @@ gfc_simplify_ior (gfc_expr * x, gfc_expr * y) ...@@ -1761,7 +1746,7 @@ gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_ishft (gfc_expr * e, gfc_expr * s) gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{ {
gfc_expr *result; gfc_expr *result;
int shift, ashift, isize, k, *bits, i; int shift, ashift, isize, k, *bits, i;
...@@ -1786,9 +1771,8 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s) ...@@ -1786,9 +1771,8 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
if (ashift > isize) if (ashift > isize)
{ {
gfc_error gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
("Magnitude of second argument of ISHFT exceeds bit size at %L", "at %L", &s->where);
&s->where);
return &gfc_bad_expr; return &gfc_bad_expr;
} }
...@@ -1840,7 +1824,7 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s) ...@@ -1840,7 +1824,7 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
gfc_expr * 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; gfc_expr *result;
int shift, ashift, isize, ssize, delta, k; int shift, ashift, isize, ssize, delta, k;
...@@ -1861,7 +1845,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz) ...@@ -1861,7 +1845,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
if (sz != NULL) if (sz != NULL)
{ {
if (sz->expr_type != EXPR_CONSTANT) if (sz->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0) 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) ...@@ -1956,7 +1940,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
gfc_expr * gfc_expr *
gfc_simplify_kind (gfc_expr * e) gfc_simplify_kind (gfc_expr *e)
{ {
if (e->ts.type == BT_DERIVED) if (e->ts.type == BT_DERIVED)
...@@ -1970,7 +1954,7 @@ gfc_simplify_kind (gfc_expr * e) ...@@ -1970,7 +1954,7 @@ gfc_simplify_kind (gfc_expr * e)
static gfc_expr * 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_ref *ref;
gfc_array_spec *as; gfc_array_spec *as;
...@@ -2077,14 +2061,14 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) ...@@ -2077,14 +2061,14 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
gfc_expr * 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); return simplify_bound (array, dim, 0);
} }
gfc_expr * gfc_expr *
gfc_simplify_len (gfc_expr * e) gfc_simplify_len (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2110,7 +2094,7 @@ gfc_simplify_len (gfc_expr * e) ...@@ -2110,7 +2094,7 @@ gfc_simplify_len (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_len_trim (gfc_expr * e) gfc_simplify_len_trim (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int count, len, lentrim, i; int count, len, lentrim, i;
...@@ -2137,9 +2121,8 @@ gfc_simplify_len_trim (gfc_expr * e) ...@@ -2137,9 +2121,8 @@ gfc_simplify_len_trim (gfc_expr * e)
gfc_expr * 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) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
...@@ -2149,9 +2132,8 @@ gfc_simplify_lge (gfc_expr * a, gfc_expr * b) ...@@ -2149,9 +2132,8 @@ gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
gfc_expr * 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) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
...@@ -2161,9 +2143,8 @@ gfc_simplify_lgt (gfc_expr * a, gfc_expr * b) ...@@ -2161,9 +2143,8 @@ gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
gfc_expr * 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) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
...@@ -2173,9 +2154,8 @@ gfc_simplify_lle (gfc_expr * a, gfc_expr * b) ...@@ -2173,9 +2154,8 @@ gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
gfc_expr * 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) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
...@@ -2185,7 +2165,7 @@ gfc_simplify_llt (gfc_expr * a, gfc_expr * b) ...@@ -2185,7 +2165,7 @@ gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
gfc_expr * gfc_expr *
gfc_simplify_log (gfc_expr * x) gfc_simplify_log (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t xr, xi; mpfr_t xr, xi;
...@@ -2202,14 +2182,13 @@ gfc_simplify_log (gfc_expr * x) ...@@ -2202,14 +2182,13 @@ gfc_simplify_log (gfc_expr * x)
case BT_REAL: case BT_REAL:
if (mpfr_sgn (x->value.real) <= 0) if (mpfr_sgn (x->value.real) <= 0)
{ {
gfc_error gfc_error ("Argument of LOG at %L cannot be less than or equal "
("Argument of LOG at %L cannot be less than or equal to zero", "to zero", &x->where);
&x->where);
gfc_free_expr (result); gfc_free_expr (result);
return &gfc_bad_expr; 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; break;
case BT_COMPLEX: case BT_COMPLEX:
...@@ -2225,8 +2204,8 @@ gfc_simplify_log (gfc_expr * x) ...@@ -2225,8 +2204,8 @@ gfc_simplify_log (gfc_expr * x)
mpfr_init (xr); mpfr_init (xr);
mpfr_init (xi); mpfr_init (xi);
mpfr_atan2 (result->value.complex.i, x->value.complex.i, x->value.complex.r, mpfr_atan2 (result->value.complex.i, x->value.complex.i,
GFC_RND_MODE); x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xr, x->value.complex.r, 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); mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
...@@ -2248,7 +2227,7 @@ gfc_simplify_log (gfc_expr * x) ...@@ -2248,7 +2227,7 @@ gfc_simplify_log (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_log10 (gfc_expr * x) gfc_simplify_log10 (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2259,9 +2238,8 @@ gfc_simplify_log10 (gfc_expr * x) ...@@ -2259,9 +2238,8 @@ gfc_simplify_log10 (gfc_expr * x)
if (mpfr_sgn (x->value.real) <= 0) if (mpfr_sgn (x->value.real) <= 0)
{ {
gfc_error gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
("Argument of LOG10 at %L cannot be less than or equal to zero", "to zero", &x->where);
&x->where);
return &gfc_bad_expr; return &gfc_bad_expr;
} }
...@@ -2274,7 +2252,7 @@ gfc_simplify_log10 (gfc_expr * x) ...@@ -2274,7 +2252,7 @@ gfc_simplify_log10 (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_logical (gfc_expr * e, gfc_expr * k) gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -2302,7 +2280,7 @@ gfc_simplify_logical (gfc_expr * e, gfc_expr * k) ...@@ -2302,7 +2280,7 @@ gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
MAX(), -1 for MIN(). */ MAX(), -1 for MIN(). */
static gfc_expr * 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_actual_arglist *arg, *last, *extremum;
gfc_intrinsic_sym * specific; gfc_intrinsic_sym * specific;
...@@ -2334,10 +2312,10 @@ simplify_min_max (gfc_expr * expr, int sign) ...@@ -2334,10 +2312,10 @@ simplify_min_max (gfc_expr * expr, int sign)
break; break;
case BT_REAL: case BT_REAL:
if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) * if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
sign > 0) * sign > 0)
mpfr_set (extremum->expr->value.real, arg->expr->value.real, mpfr_set (extremum->expr->value.real, arg->expr->value.real,
GFC_RND_MODE); GFC_RND_MODE);
break; break;
...@@ -2375,21 +2353,21 @@ simplify_min_max (gfc_expr * expr, int sign) ...@@ -2375,21 +2353,21 @@ simplify_min_max (gfc_expr * expr, int sign)
gfc_expr * gfc_expr *
gfc_simplify_min (gfc_expr * e) gfc_simplify_min (gfc_expr *e)
{ {
return simplify_min_max (e, -1); return simplify_min_max (e, -1);
} }
gfc_expr * gfc_expr *
gfc_simplify_max (gfc_expr * e) gfc_simplify_max (gfc_expr *e)
{ {
return simplify_min_max (e, 1); return simplify_min_max (e, 1);
} }
gfc_expr * gfc_expr *
gfc_simplify_maxexponent (gfc_expr * x) gfc_simplify_maxexponent (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -2404,7 +2382,7 @@ gfc_simplify_maxexponent (gfc_expr * x) ...@@ -2404,7 +2382,7 @@ gfc_simplify_maxexponent (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_minexponent (gfc_expr * x) gfc_simplify_minexponent (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -2419,7 +2397,7 @@ gfc_simplify_minexponent (gfc_expr * x) ...@@ -2419,7 +2397,7 @@ gfc_simplify_minexponent (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_mod (gfc_expr * a, gfc_expr * p) gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t quot, iquot, term; mpfr_t quot, iquot, term;
...@@ -2477,7 +2455,7 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p) ...@@ -2477,7 +2455,7 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
gfc_expr * gfc_expr *
gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t quot, iquot, term; mpfr_t quot, iquot, term;
...@@ -2495,7 +2473,7 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) ...@@ -2495,7 +2473,7 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
if (mpz_cmp_ui (p->value.integer, 0) == 0) if (mpz_cmp_ui (p->value.integer, 0) == 0)
{ {
/* Result is processor-dependent. This processor just opts /* 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_error ("Second argument of MODULO at %L is zero", &a->where);
gfc_free_expr (result); gfc_free_expr (result);
return &gfc_bad_expr; return &gfc_bad_expr;
...@@ -2538,18 +2516,18 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) ...@@ -2538,18 +2516,18 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
/* Exists for the sole purpose of consistency with other intrinsics. */ /* Exists for the sole purpose of consistency with other intrinsics. */
gfc_expr * gfc_expr *
gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED, gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
gfc_expr * fp ATTRIBUTE_UNUSED, gfc_expr *fp ATTRIBUTE_UNUSED,
gfc_expr * l ATTRIBUTE_UNUSED, gfc_expr *l ATTRIBUTE_UNUSED,
gfc_expr * to ATTRIBUTE_UNUSED, gfc_expr *to ATTRIBUTE_UNUSED,
gfc_expr * tp ATTRIBUTE_UNUSED) gfc_expr *tp ATTRIBUTE_UNUSED)
{ {
return NULL; return NULL;
} }
gfc_expr * gfc_expr *
gfc_simplify_nearest (gfc_expr * x, gfc_expr * s) gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t tmp; mpfr_t tmp;
...@@ -2560,7 +2538,8 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s) ...@@ -2560,7 +2538,8 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
if (mpfr_sgn (s->value.real) == 0) 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; return &gfc_bad_expr;
} }
...@@ -2571,14 +2550,14 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s) ...@@ -2571,14 +2550,14 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
mpfr_init (tmp); mpfr_init (tmp);
mpfr_set_inf (tmp, sgn); mpfr_set_inf (tmp, sgn);
mpfr_nexttoward (result->value.real, tmp); mpfr_nexttoward (result->value.real, tmp);
mpfr_clear(tmp); mpfr_clear (tmp);
return range_check (result, "NEAREST"); return range_check (result, "NEAREST");
} }
static gfc_expr * 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; gfc_expr *itrunc, *result;
int kind; int kind;
...@@ -2594,7 +2573,7 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k) ...@@ -2594,7 +2573,7 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
itrunc = gfc_copy_expr (e); 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); 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) ...@@ -2605,7 +2584,7 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_new_line (gfc_expr * e) gfc_simplify_new_line (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2624,21 +2603,21 @@ gfc_simplify_new_line (gfc_expr * e) ...@@ -2624,21 +2603,21 @@ gfc_simplify_new_line (gfc_expr * e)
gfc_expr * 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); return simplify_nint ("NINT", e, k);
} }
gfc_expr * gfc_expr *
gfc_simplify_idnint (gfc_expr * e) gfc_simplify_idnint (gfc_expr *e)
{ {
return simplify_nint ("IDNINT", e, NULL); return simplify_nint ("IDNINT", e, NULL);
} }
gfc_expr * gfc_expr *
gfc_simplify_not (gfc_expr * e) gfc_simplify_not (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2654,7 +2633,7 @@ gfc_simplify_not (gfc_expr * e) ...@@ -2654,7 +2633,7 @@ gfc_simplify_not (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_null (gfc_expr * mold) gfc_simplify_null (gfc_expr *mold)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2672,7 +2651,7 @@ gfc_simplify_null (gfc_expr * mold) ...@@ -2672,7 +2651,7 @@ gfc_simplify_null (gfc_expr * mold)
gfc_expr * gfc_expr *
gfc_simplify_or (gfc_expr * x, gfc_expr * y) gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -2697,7 +2676,7 @@ gfc_simplify_or (gfc_expr * x, gfc_expr * y) ...@@ -2697,7 +2676,7 @@ gfc_simplify_or (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_precision (gfc_expr * e) gfc_simplify_precision (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -2712,7 +2691,7 @@ gfc_simplify_precision (gfc_expr * e) ...@@ -2712,7 +2691,7 @@ gfc_simplify_precision (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_radix (gfc_expr * e) gfc_simplify_radix (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -2740,7 +2719,7 @@ gfc_simplify_radix (gfc_expr * e) ...@@ -2740,7 +2719,7 @@ gfc_simplify_radix (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_range (gfc_expr * e) gfc_simplify_range (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -2771,7 +2750,7 @@ gfc_simplify_range (gfc_expr * e) ...@@ -2771,7 +2750,7 @@ gfc_simplify_range (gfc_expr * e)
gfc_expr * gfc_expr *
gfc_simplify_real (gfc_expr * e, gfc_expr * k) gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -2811,7 +2790,7 @@ gfc_simplify_real (gfc_expr * e, gfc_expr * k) ...@@ -2811,7 +2790,7 @@ gfc_simplify_real (gfc_expr * e, gfc_expr * k)
gfc_expr * gfc_expr *
gfc_simplify_realpart (gfc_expr * e) gfc_simplify_realpart (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -2825,7 +2804,7 @@ gfc_simplify_realpart (gfc_expr * e) ...@@ -2825,7 +2804,7 @@ gfc_simplify_realpart (gfc_expr * e)
} }
gfc_expr * gfc_expr *
gfc_simplify_repeat (gfc_expr * e, gfc_expr * n) gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
{ {
gfc_expr *result; gfc_expr *result;
int i, j, len, ncopies, nlen; int i, j, len, ncopies, nlen;
...@@ -2857,8 +2836,8 @@ gfc_simplify_repeat (gfc_expr * e, gfc_expr * n) ...@@ -2857,8 +2836,8 @@ gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
for (i = 0; i < ncopies; i++) for (i = 0; i < ncopies; i++)
for (j = 0; j < len; j++) for (j = 0; j < len; j++)
result->value.character.string[j + i * len] = result->value.character.string[j + i * len]
e->value.character.string[j]; = e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */ result->value.character.string[nlen] = '\0'; /* For debugger */
return result; return result;
...@@ -2868,10 +2847,9 @@ gfc_simplify_repeat (gfc_expr * e, gfc_expr * n) ...@@ -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. */ /* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr * gfc_expr *
gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
gfc_expr * pad, gfc_expr * order_exp) gfc_expr *pad, gfc_expr *order_exp)
{ {
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS]; int i, rank, npad, x[GFC_MAX_DIMENSIONS];
gfc_constructor *head, *tail; gfc_constructor *head, *tail;
...@@ -2888,8 +2866,7 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, ...@@ -2888,8 +2866,7 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
return NULL; return NULL;
if (pad != NULL if (pad != NULL
&& (pad->expr_type != EXPR_ARRAY && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
|| !gfc_is_constant_expr (pad)))
return NULL; return NULL;
if (order_exp != NULL if (order_exp != NULL
...@@ -2947,11 +2924,9 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, ...@@ -2947,11 +2924,9 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
{ {
for (i = 0; i < rank; i++) for (i = 0; i < rank; i++)
order[i] = i; order[i] = i;
} }
else else
{ {
for (i = 0; i < rank; i++) for (i = 0; i < rank; i++)
x[i] = 0; x[i] = 0;
...@@ -2960,9 +2935,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, ...@@ -2960,9 +2935,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
e = gfc_get_array_element (order_exp, i); e = gfc_get_array_element (order_exp, i);
if (e == NULL) if (e == NULL)
{ {
gfc_error gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
("ORDER parameter of RESHAPE at %L is not the same size " "size as SHAPE parameter", &order_exp->where);
"as SHAPE parameter", &order_exp->where);
goto bad_reshape; goto bad_reshape;
} }
...@@ -3043,9 +3017,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, ...@@ -3043,9 +3017,8 @@ gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
if (npad == 0) if (npad == 0)
{ {
gfc_error gfc_error ("PAD parameter required for short SOURCE parameter "
("PAD parameter required for short SOURCE parameter at %L", "at %L", &source->where);
&source->where);
goto bad_reshape; goto bad_reshape;
} }
...@@ -3104,7 +3077,7 @@ bad_reshape: ...@@ -3104,7 +3077,7 @@ bad_reshape:
gfc_expr * gfc_expr *
gfc_simplify_rrspacing (gfc_expr * x) gfc_simplify_rrspacing (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -3119,7 +3092,7 @@ gfc_simplify_rrspacing (gfc_expr * x) ...@@ -3119,7 +3092,7 @@ gfc_simplify_rrspacing (gfc_expr * x)
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); 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) if (mpfr_sgn (result->value.real) == 0)
{ {
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
...@@ -3138,7 +3111,7 @@ gfc_simplify_rrspacing (gfc_expr * x) ...@@ -3138,7 +3111,7 @@ gfc_simplify_rrspacing (gfc_expr * x)
gfc_expr * 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; int k, neg_flag, power, exp_range;
mpfr_t scale, radix; mpfr_t scale, radix;
...@@ -3197,7 +3170,7 @@ gfc_simplify_scale (gfc_expr * x, gfc_expr * i) ...@@ -3197,7 +3170,7 @@ gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
gfc_expr * 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; gfc_expr *result;
int back; int back;
...@@ -3225,27 +3198,27 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b) ...@@ -3225,27 +3198,27 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
else else
{ {
if (back == 0) if (back == 0)
{ {
indx = indx = strcspn (e->value.character.string, c->value.character.string)
strcspn (e->value.character.string, c->value.character.string) + 1; + 1;
if (indx > len) if (indx > len)
indx = 0; indx = 0;
} }
else else
{ {
i = 0; i = 0;
for (indx = len; indx > 0; indx--) for (indx = len; indx > 0; indx--)
{ {
for (i = 0; i < lenc; i++) for (i = 0; i < lenc; i++)
{ {
if (c->value.character.string[i] if (c->value.character.string[i]
== e->value.character.string[indx - 1]) == e->value.character.string[indx - 1])
break; break;
} }
if (i < lenc) if (i < lenc)
break; break;
} }
} }
} }
mpz_set_ui (result->value.integer, indx); mpz_set_ui (result->value.integer, indx);
return range_check (result, "SCAN"); return range_check (result, "SCAN");
...@@ -3253,7 +3226,7 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b) ...@@ -3253,7 +3226,7 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
gfc_expr * gfc_expr *
gfc_simplify_selected_int_kind (gfc_expr * e) gfc_simplify_selected_int_kind (gfc_expr *e)
{ {
int i, kind, range; int i, kind, range;
gfc_expr *result; gfc_expr *result;
...@@ -3279,7 +3252,7 @@ gfc_simplify_selected_int_kind (gfc_expr * e) ...@@ -3279,7 +3252,7 @@ gfc_simplify_selected_int_kind (gfc_expr * e)
gfc_expr * 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; int range, precision, i, kind, found_precision, found_range;
gfc_expr *result; gfc_expr *result;
...@@ -3337,7 +3310,7 @@ gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q) ...@@ -3337,7 +3310,7 @@ gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
gfc_expr * 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; gfc_expr *result;
mpfr_t exp, absv, log2, pow2, frac; mpfr_t exp, absv, log2, pow2, frac;
...@@ -3387,7 +3360,7 @@ gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i) ...@@ -3387,7 +3360,7 @@ gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
gfc_expr * gfc_expr *
gfc_simplify_shape (gfc_expr * source) gfc_simplify_shape (gfc_expr *source)
{ {
mpz_t shape[GFC_MAX_DIMENSIONS]; mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f; gfc_expr *result, *e, *f;
...@@ -3440,7 +3413,7 @@ gfc_simplify_shape (gfc_expr * source) ...@@ -3440,7 +3413,7 @@ gfc_simplify_shape (gfc_expr * source)
gfc_expr * gfc_expr *
gfc_simplify_size (gfc_expr * array, gfc_expr * dim) gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
{ {
mpz_t size; mpz_t size;
gfc_expr *result; gfc_expr *result;
...@@ -3471,7 +3444,7 @@ gfc_simplify_size (gfc_expr * array, gfc_expr * dim) ...@@ -3471,7 +3444,7 @@ gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
gfc_expr * gfc_expr *
gfc_simplify_sign (gfc_expr * x, gfc_expr * y) gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -3491,7 +3464,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y) ...@@ -3491,7 +3464,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
case BT_REAL: case BT_REAL:
/* TODO: Handle -0.0 and +0.0 correctly on machines that support /* 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); mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
if (mpfr_sgn (y->value.real) < 0) if (mpfr_sgn (y->value.real) < 0)
mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
...@@ -3507,7 +3480,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y) ...@@ -3507,7 +3480,7 @@ gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
gfc_expr * gfc_expr *
gfc_simplify_sin (gfc_expr * x) gfc_simplify_sin (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t xp, xq; mpfr_t xp, xq;
...@@ -3549,7 +3522,7 @@ gfc_simplify_sin (gfc_expr * x) ...@@ -3549,7 +3522,7 @@ gfc_simplify_sin (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_sinh (gfc_expr * x) gfc_simplify_sinh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -3558,7 +3531,7 @@ gfc_simplify_sinh (gfc_expr * x) ...@@ -3558,7 +3531,7 @@ gfc_simplify_sinh (gfc_expr * x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); 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"); return range_check (result, "SINH");
} }
...@@ -3568,7 +3541,7 @@ gfc_simplify_sinh (gfc_expr * x) ...@@ -3568,7 +3541,7 @@ gfc_simplify_sinh (gfc_expr * x)
single precision. TODO: Rounding! */ single precision. TODO: Rounding! */
gfc_expr * gfc_expr *
gfc_simplify_sngl (gfc_expr * a) gfc_simplify_sngl (gfc_expr *a)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -3581,7 +3554,7 @@ gfc_simplify_sngl (gfc_expr * a) ...@@ -3581,7 +3554,7 @@ gfc_simplify_sngl (gfc_expr * a)
gfc_expr * gfc_expr *
gfc_simplify_spacing (gfc_expr * x) gfc_simplify_spacing (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -3619,7 +3592,7 @@ gfc_simplify_spacing (gfc_expr * x) ...@@ -3619,7 +3592,7 @@ gfc_simplify_spacing (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_sqrt (gfc_expr * e) gfc_simplify_sqrt (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
mpfr_t ac, ad, s, t, w; mpfr_t ac, ad, s, t, w;
...@@ -3640,7 +3613,7 @@ gfc_simplify_sqrt (gfc_expr * e) ...@@ -3640,7 +3613,7 @@ gfc_simplify_sqrt (gfc_expr * e)
case BT_COMPLEX: case BT_COMPLEX:
/* Formula taken from Numerical Recipes to avoid over- and /* Formula taken from Numerical Recipes to avoid over- and
underflow. */ underflow. */
gfc_set_model (e->value.real); gfc_set_model (e->value.real);
mpfr_init (ac); mpfr_init (ac);
...@@ -3652,7 +3625,6 @@ gfc_simplify_sqrt (gfc_expr * e) ...@@ -3652,7 +3625,6 @@ gfc_simplify_sqrt (gfc_expr * e)
if (mpfr_cmp_ui (e->value.complex.r, 0) == 0 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
&& mpfr_cmp_ui (e->value.complex.i, 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.r, 0, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break; break;
...@@ -3736,7 +3708,7 @@ negative_arg: ...@@ -3736,7 +3708,7 @@ negative_arg:
gfc_expr * gfc_expr *
gfc_simplify_tan (gfc_expr * x) gfc_simplify_tan (gfc_expr *x)
{ {
int i; int i;
gfc_expr *result; gfc_expr *result;
...@@ -3755,7 +3727,7 @@ gfc_simplify_tan (gfc_expr * x) ...@@ -3755,7 +3727,7 @@ gfc_simplify_tan (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_tanh (gfc_expr * x) gfc_simplify_tanh (gfc_expr *x)
{ {
gfc_expr *result; gfc_expr *result;
...@@ -3772,7 +3744,7 @@ gfc_simplify_tanh (gfc_expr * x) ...@@ -3772,7 +3744,7 @@ gfc_simplify_tanh (gfc_expr * x)
gfc_expr * gfc_expr *
gfc_simplify_tiny (gfc_expr * e) gfc_simplify_tiny (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int i; int i;
...@@ -3787,9 +3759,8 @@ gfc_simplify_tiny (gfc_expr * e) ...@@ -3787,9 +3759,8 @@ gfc_simplify_tiny (gfc_expr * e)
gfc_expr * 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. */ /* Reference mold and size to suppress warning. */
if (gfc_init_expr && (mold || size)) if (gfc_init_expr && (mold || size))
gfc_error ("TRANSFER intrinsic not implemented for initialization at %L", 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) ...@@ -3800,7 +3771,7 @@ gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
gfc_expr * gfc_expr *
gfc_simplify_trim (gfc_expr * e) gfc_simplify_trim (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
int count, i, len, lentrim; int count, i, len, lentrim;
...@@ -3835,14 +3806,14 @@ gfc_simplify_trim (gfc_expr * e) ...@@ -3835,14 +3806,14 @@ gfc_simplify_trim (gfc_expr * e)
gfc_expr * 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); return simplify_bound (array, dim, 1);
} }
gfc_expr * 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; gfc_expr *result;
int back; int back;
...@@ -3877,8 +3848,8 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b) ...@@ -3877,8 +3848,8 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
return result; return result;
} }
index = index = strspn (s->value.character.string, set->value.character.string)
strspn (s->value.character.string, set->value.character.string) + 1; + 1;
if (index > len) if (index > len)
index = 0; index = 0;
...@@ -3891,16 +3862,16 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b) ...@@ -3891,16 +3862,16 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
return result; return result;
} }
for (index = len; index > 0; index --) for (index = len; index > 0; index --)
{ {
for (i = 0; i < lenset; i++) for (i = 0; i < lenset; i++)
{ {
if (s->value.character.string[index - 1] if (s->value.character.string[index - 1]
== set->value.character.string[i]) == set->value.character.string[i])
break; break;
} }
if (i == lenset) if (i == lenset)
break; break;
} }
} }
mpz_set_ui (result->value.integer, index); mpz_set_ui (result->value.integer, index);
...@@ -3909,7 +3880,7 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b) ...@@ -3909,7 +3880,7 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
gfc_expr * gfc_expr *
gfc_simplify_xor (gfc_expr * x, gfc_expr * y) gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
{ {
gfc_expr *result; gfc_expr *result;
int kind; int kind;
...@@ -3926,15 +3897,14 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y) ...@@ -3926,15 +3897,14 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
else /* BT_LOGICAL */ else /* BT_LOGICAL */
{ {
result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
result->value.logical = (x->value.logical && ! y->value.logical) result->value.logical = (x->value.logical && !y->value.logical)
|| (! x->value.logical && y->value.logical); || (!x->value.logical && y->value.logical);
} }
return range_check (result, "XOR"); return range_check (result, "XOR");
} }
/****************** Constant simplification *****************/ /****************** Constant simplification *****************/
/* Master function to convert one constant to another. While this is /* Master function to convert one constant to another. While this is
...@@ -3943,7 +3913,7 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y) ...@@ -3943,7 +3913,7 @@ gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
do_simplify(). */ do_simplify(). */
gfc_expr * 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_expr *g, *result, *(*f) (gfc_expr *, int);
gfc_constructor *head, *c, *tail = NULL; gfc_constructor *head, *c, *tail = NULL;
...@@ -4135,6 +4105,5 @@ invert_table (const int *table, int *xtable) ...@@ -4135,6 +4105,5 @@ invert_table (const int *table, int *xtable)
void void
gfc_simplify_init_1 (void) gfc_simplify_init_1 (void)
{ {
invert_table (ascii_table, xascii_table); invert_table (ascii_table, xascii_table);
} }
gcc/fortran/st.c
/* Build executable statement trees. /* 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. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
...@@ -37,7 +37,6 @@ gfc_code new_st; ...@@ -37,7 +37,6 @@ gfc_code new_st;
void void
gfc_clear_new_st (void) gfc_clear_new_st (void)
{ {
memset (&new_st, '\0', sizeof (new_st)); memset (&new_st, '\0', sizeof (new_st));
new_st.op = EXEC_NOP; new_st.op = EXEC_NOP;
} }
...@@ -60,9 +59,8 @@ gfc_get_code (void) ...@@ -60,9 +59,8 @@ gfc_get_code (void)
its tail, returning a pointer to the new tail. */ its tail, returning a pointer to the new tail. */
gfc_code * gfc_code *
gfc_append_code (gfc_code * tail, gfc_code * new) gfc_append_code (gfc_code *tail, gfc_code *new)
{ {
if (tail != NULL) if (tail != NULL)
{ {
while (tail->next != NULL) while (tail->next != NULL)
...@@ -81,9 +79,8 @@ gfc_append_code (gfc_code * tail, gfc_code * new) ...@@ -81,9 +79,8 @@ gfc_append_code (gfc_code * tail, gfc_code * new)
/* Free a single code structure, but not the actual structure itself. */ /* Free a single code structure, but not the actual structure itself. */
void void
gfc_free_statement (gfc_code * p) gfc_free_statement (gfc_code *p)
{ {
if (p->expr) if (p->expr)
gfc_free_expr (p->expr); gfc_free_expr (p->expr);
if (p->expr2) if (p->expr2)
...@@ -157,7 +154,7 @@ gfc_free_statement (gfc_code * p) ...@@ -157,7 +154,7 @@ gfc_free_statement (gfc_code * p)
case EXEC_DT_END: case EXEC_DT_END:
/* The ext.dt member is a duplicate pointer and doesn't need to /* The ext.dt member is a duplicate pointer and doesn't need to
be freed. */ be freed. */
break; break;
case EXEC_FORALL: case EXEC_FORALL:
...@@ -200,7 +197,7 @@ gfc_free_statement (gfc_code * p) ...@@ -200,7 +197,7 @@ gfc_free_statement (gfc_code * p)
/* Free a code statement and all other code structures linked to it. */ /* Free a code statement and all other code structures linked to it. */
void void
gfc_free_statements (gfc_code * p) gfc_free_statements (gfc_code *p)
{ {
gfc_code *q; 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