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 902 additions and 993 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");
...@@ -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);
...@@ -1006,7 +1001,7 @@ parse_string (void) ...@@ -1006,7 +1001,7 @@ parse_string (void)
} }
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 ();
...@@ -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;
...@@ -2245,8 +2229,9 @@ mio_symtree_ref (gfc_symtree ** stp) ...@@ -2245,8 +2229,9 @@ mio_symtree_ref (gfc_symtree ** 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;
...@@ -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;
...@@ -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 ();
...@@ -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);
} }
...@@ -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,7 +4046,7 @@ gfc_use_module (void) ...@@ -4073,7 +4046,7 @@ 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,8 +4062,8 @@ gfc_use_module (void) ...@@ -4089,8 +4062,8 @@ 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;
...@@ -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,6 +345,7 @@ gfc_handle_module_path_options (const char *arg) ...@@ -350,6 +345,7 @@ 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)
{ {
...@@ -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;
...@@ -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;
} }
...@@ -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;
...@@ -729,15 +727,13 @@ next_statement (void) ...@@ -729,15 +727,13 @@ next_statement (void)
/* 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;
...@@ -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:
...@@ -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 ();
...@@ -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)
...@@ -1468,8 +1461,7 @@ verify_st_order (st_state * p, gfc_statement st) ...@@ -1468,8 +1461,7 @@ 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));
} }
...@@ -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
...@@ -1682,6 +1673,7 @@ parse_enum (void) ...@@ -1682,6 +1673,7 @@ parse_enum (void)
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");
} }
} }
} }
...@@ -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 ();
} }
...@@ -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,8 +2322,7 @@ loop: ...@@ -2336,8 +2322,7 @@ 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;
...@@ -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,7 +2740,7 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) ...@@ -2756,7 +2740,7 @@ 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;
...@@ -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,
...@@ -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");
} }
...@@ -3038,7 +3019,8 @@ parse_block_data (void) ...@@ -3038,7 +3019,8 @@ parse_block_data (void)
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
{ {
...@@ -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;
...@@ -246,9 +245,8 @@ match_hollerith_constant (gfc_expr ** result) ...@@ -246,9 +245,8 @@ match_hollerith_constant (gfc_expr ** result)
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,8 +257,8 @@ match_hollerith_constant (gfc_expr ** result) ...@@ -259,8 +257,8 @@ 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)
...@@ -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;
...@@ -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;
...@@ -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;
...@@ -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;
...@@ -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;
...@@ -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];
...@@ -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;
...@@ -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
/* Perform type resolution on the various stuctures. /* Perform type resolution on the various stuctures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Copyright (C) 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 "flags.h" #include "flags.h"
...@@ -83,7 +82,7 @@ gfc_is_formal_arg (void) ...@@ -83,7 +82,7 @@ gfc_is_formal_arg (void)
resort left for untyped names are the IMPLICIT types. */ resort left for untyped names are the IMPLICIT types. */
static void static void
resolve_formal_arglist (gfc_symbol * proc) resolve_formal_arglist (gfc_symbol *proc)
{ {
gfc_formal_arglist *f; gfc_formal_arglist *f;
gfc_symbol *sym; gfc_symbol *sym;
...@@ -126,17 +125,15 @@ resolve_formal_arglist (gfc_symbol * proc) ...@@ -126,17 +125,15 @@ resolve_formal_arglist (gfc_symbol * proc)
{ {
if (gfc_pure (proc) && !gfc_pure (sym)) if (gfc_pure (proc) && !gfc_pure (sym))
{ {
gfc_error gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
("Dummy procedure '%s' of PURE procedure at %L must also " "also be PURE", sym->name, &sym->declared_at);
"be PURE", sym->name, &sym->declared_at);
continue; continue;
} }
if (gfc_elemental (proc)) if (gfc_elemental (proc))
{ {
gfc_error gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
("Dummy procedure at %L not allowed in ELEMENTAL procedure", "procedure", &sym->declared_at);
&sym->declared_at);
continue; continue;
} }
...@@ -206,17 +203,16 @@ resolve_formal_arglist (gfc_symbol * proc) ...@@ -206,17 +203,16 @@ resolve_formal_arglist (gfc_symbol * proc)
{ {
if (sym->as != NULL) if (sym->as != NULL)
{ {
gfc_error gfc_error ("Argument '%s' of elemental procedure at %L must "
("Argument '%s' of elemental procedure at %L must be scalar", "be scalar", sym->name, &sym->declared_at);
sym->name, &sym->declared_at);
continue; continue;
} }
if (sym->attr.pointer) if (sym->attr.pointer)
{ {
gfc_error gfc_error ("Argument '%s' of elemental procedure at %L cannot "
("Argument '%s' of elemental procedure at %L cannot have " "have the POINTER attribute", sym->name,
"the POINTER attribute", sym->name, &sym->declared_at); &sym->declared_at);
continue; continue;
} }
} }
...@@ -226,9 +222,8 @@ resolve_formal_arglist (gfc_symbol * proc) ...@@ -226,9 +222,8 @@ resolve_formal_arglist (gfc_symbol * proc)
{ {
if (sym->as != NULL) if (sym->as != NULL)
{ {
gfc_error gfc_error ("Argument '%s' of statement function at %L must "
("Argument '%s' of statement function at %L must be scalar", "be scalar", sym->name, &sym->declared_at);
sym->name, &sym->declared_at);
continue; continue;
} }
...@@ -237,9 +232,8 @@ resolve_formal_arglist (gfc_symbol * proc) ...@@ -237,9 +232,8 @@ resolve_formal_arglist (gfc_symbol * proc)
gfc_charlen *cl = sym->ts.cl; gfc_charlen *cl = sym->ts.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{ {
gfc_error gfc_error ("Character-valued argument '%s' of statement "
("Character-valued argument '%s' of statement function at " "function at %L must have constant length",
"%L must have constant length",
sym->name, &sym->declared_at); sym->name, &sym->declared_at);
continue; continue;
} }
...@@ -254,9 +248,8 @@ resolve_formal_arglist (gfc_symbol * proc) ...@@ -254,9 +248,8 @@ resolve_formal_arglist (gfc_symbol * proc)
associated with them. */ associated with them. */
static void static void
find_arglists (gfc_symbol * sym) find_arglists (gfc_symbol *sym)
{ {
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns) if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
return; return;
...@@ -268,9 +261,8 @@ find_arglists (gfc_symbol * sym) ...@@ -268,9 +261,8 @@ find_arglists (gfc_symbol * sym)
*/ */
static void static void
resolve_formal_arglists (gfc_namespace * ns) resolve_formal_arglists (gfc_namespace *ns)
{ {
if (ns == NULL) if (ns == NULL)
return; return;
...@@ -279,14 +271,12 @@ resolve_formal_arglists (gfc_namespace * ns) ...@@ -279,14 +271,12 @@ resolve_formal_arglists (gfc_namespace * ns)
static void static void
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{ {
try t; try t;
/* If this namespace is not a function, ignore it. */ /* If this namespace is not a function, ignore it. */
if (! sym if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
|| !(sym->attr.function
|| sym->attr.flavor == FL_VARIABLE))
return; return;
/* Try to find out of what the return type is. */ /* Try to find out of what the return type is. */
...@@ -305,10 +295,11 @@ resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) ...@@ -305,10 +295,11 @@ resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
} }
} }
/*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type, /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
lists the only ways a character length value of * can be used: dummy arguments type, lists the only ways a character length value of * can be used:
of procedures, named constants, and function results in external functions. dummy arguments of procedures, named constants, and function results
Internal function results are not on that list; ergo, not permitted. */ in external functions. Internal function results are not on that list;
ergo, not permitted. */
if (sym->ts.type == BT_CHARACTER) if (sym->ts.type == BT_CHARACTER)
{ {
...@@ -383,7 +374,7 @@ check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) ...@@ -383,7 +374,7 @@ check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
symbol into an entry point. */ symbol into an entry point. */
static void static void
resolve_entries (gfc_namespace * ns) resolve_entries (gfc_namespace *ns)
{ {
gfc_namespace *old_ns; gfc_namespace *old_ns;
gfc_code *c; gfc_code *c;
...@@ -426,8 +417,7 @@ resolve_entries (gfc_namespace * ns) ...@@ -426,8 +417,7 @@ resolve_entries (gfc_namespace * ns)
left in their own namespace, to keep prior references linked to left in their own namespace, to keep prior references linked to
the entry declaration.*/ the entry declaration.*/
if (ns->proc_name->attr.function if (ns->proc_name->attr.function
&& ns->parent && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
&& ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns; el->sym->ns = ns;
/* Add an entry statement for it. */ /* Add an entry statement for it. */
...@@ -503,24 +493,24 @@ resolve_entries (gfc_namespace * ns) ...@@ -503,24 +493,24 @@ resolve_entries (gfc_namespace * ns)
if (sym->attr.dimension) if (sym->attr.dimension)
{ {
if (el == ns->entries) if (el == ns->entries)
gfc_error gfc_error ("FUNCTION result %s can't be an array in "
("FUNCTION result %s can't be an array in FUNCTION %s at %L", "FUNCTION %s at %L", sym->name,
sym->name, ns->entries->sym->name, &sym->declared_at); ns->entries->sym->name, &sym->declared_at);
else else
gfc_error gfc_error ("ENTRY result %s can't be an array in "
("ENTRY result %s can't be an array in FUNCTION %s at %L", "FUNCTION %s at %L", sym->name,
sym->name, ns->entries->sym->name, &sym->declared_at); ns->entries->sym->name, &sym->declared_at);
} }
else if (sym->attr.pointer) else if (sym->attr.pointer)
{ {
if (el == ns->entries) if (el == ns->entries)
gfc_error gfc_error ("FUNCTION result %s can't be a POINTER in "
("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L", "FUNCTION %s at %L", sym->name,
sym->name, ns->entries->sym->name, &sym->declared_at); ns->entries->sym->name, &sym->declared_at);
else else
gfc_error gfc_error ("ENTRY result %s can't be a POINTER in "
("ENTRY result %s can't be a POINTER in FUNCTION %s at %L", "FUNCTION %s at %L", sym->name,
sym->name, ns->entries->sym->name, &sym->declared_at); ns->entries->sym->name, &sym->declared_at);
} }
else else
{ {
...@@ -556,14 +546,14 @@ resolve_entries (gfc_namespace * ns) ...@@ -556,14 +546,14 @@ resolve_entries (gfc_namespace * ns)
if (sym) if (sym)
{ {
if (el == ns->entries) if (el == ns->entries)
gfc_error gfc_error ("FUNCTION result %s can't be of type %s "
("FUNCTION result %s can't be of type %s in FUNCTION %s at %L", "in FUNCTION %s at %L", sym->name,
sym->name, gfc_typename (ts), ns->entries->sym->name, gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at); &sym->declared_at);
else else
gfc_error gfc_error ("ENTRY result %s can't be of type %s "
("ENTRY result %s can't be of type %s in FUNCTION %s at %L", "in FUNCTION %s at %L", sym->name,
sym->name, gfc_typename (ts), ns->entries->sym->name, gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at); &sym->declared_at);
} }
} }
...@@ -603,7 +593,7 @@ resolve_entries (gfc_namespace * ns) ...@@ -603,7 +593,7 @@ resolve_entries (gfc_namespace * ns)
in, not in a sibling or parent namespace. */ in, not in a sibling or parent namespace. */
static void static void
resolve_contained_functions (gfc_namespace * ns) resolve_contained_functions (gfc_namespace *ns)
{ {
gfc_namespace *child; gfc_namespace *child;
gfc_entry_list *el; gfc_entry_list *el;
...@@ -627,7 +617,7 @@ resolve_contained_functions (gfc_namespace * ns) ...@@ -627,7 +617,7 @@ resolve_contained_functions (gfc_namespace * ns)
the types are correct. */ the types are correct. */
static try static try
resolve_structure_cons (gfc_expr * expr) resolve_structure_cons (gfc_expr *expr)
{ {
gfc_constructor *cons; gfc_constructor *cons;
gfc_component *comp; gfc_component *comp;
...@@ -646,7 +636,7 @@ resolve_structure_cons (gfc_expr * expr) ...@@ -646,7 +636,7 @@ resolve_structure_cons (gfc_expr * expr)
for (; comp; comp = comp->next, cons = cons->next) for (; comp; comp = comp->next, cons = cons->next)
{ {
if (! cons->expr) if (!cons->expr)
continue; continue;
if (gfc_resolve_expr (cons->expr) == FAILURE) if (gfc_resolve_expr (cons->expr) == FAILURE)
...@@ -699,14 +689,13 @@ resolve_structure_cons (gfc_expr * expr) ...@@ -699,14 +689,13 @@ resolve_structure_cons (gfc_expr * expr)
} }
/****************** Expression name resolution ******************/ /****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or /* Returns 0 if a symbol was not declared with a type or
attribute declaration statement, nonzero otherwise. */ attribute declaration statement, nonzero otherwise. */
static int static int
was_declared (gfc_symbol * sym) was_declared (gfc_symbol *sym)
{ {
symbol_attribute a; symbol_attribute a;
...@@ -716,8 +705,8 @@ was_declared (gfc_symbol * sym) ...@@ -716,8 +705,8 @@ was_declared (gfc_symbol * sym)
return 1; return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.optional || a.pointer || a.save || a.target || a.volatile_
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN) || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1; return 1;
return 0; return 0;
...@@ -727,7 +716,7 @@ was_declared (gfc_symbol * sym) ...@@ -727,7 +716,7 @@ was_declared (gfc_symbol * sym)
/* Determine if a symbol is generic or not. */ /* Determine if a symbol is generic or not. */
static int static int
generic_sym (gfc_symbol * sym) generic_sym (gfc_symbol *sym)
{ {
gfc_symbol *s; gfc_symbol *s;
...@@ -747,7 +736,7 @@ generic_sym (gfc_symbol * sym) ...@@ -747,7 +736,7 @@ generic_sym (gfc_symbol * sym)
/* Determine if a symbol is specific or not. */ /* Determine if a symbol is specific or not. */
static int static int
specific_sym (gfc_symbol * sym) specific_sym (gfc_symbol *sym)
{ {
gfc_symbol *s; gfc_symbol *s;
...@@ -755,8 +744,7 @@ specific_sym (gfc_symbol * sym) ...@@ -755,8 +744,7 @@ specific_sym (gfc_symbol * sym)
|| sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_INTERNAL || sym->attr.proc == PROC_INTERNAL
|| sym->attr.proc == PROC_ST_FUNCTION || sym->attr.proc == PROC_ST_FUNCTION
|| (sym->attr.intrinsic && || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
gfc_specific_intrinsic (sym->name))
|| sym->attr.external) || sym->attr.external)
return 1; return 1;
...@@ -776,9 +764,8 @@ typedef enum ...@@ -776,9 +764,8 @@ typedef enum
proc_type; proc_type;
static proc_type static proc_type
procedure_kind (gfc_symbol * sym) procedure_kind (gfc_symbol *sym)
{ {
if (generic_sym (sym)) if (generic_sym (sym))
return PTYPE_GENERIC; return PTYPE_GENERIC;
...@@ -794,20 +781,20 @@ procedure_kind (gfc_symbol * sym) ...@@ -794,20 +781,20 @@ procedure_kind (gfc_symbol * sym)
static int need_full_assumed_size = 0; static int need_full_assumed_size = 0;
static bool static bool
check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e) check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
{ {
gfc_ref * ref; gfc_ref *ref;
int dim; int dim;
int last = 1; int last = 1;
if (need_full_assumed_size if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false; return false;
for (ref = e->ref; ref; ref = ref->next) for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY) if (ref->type == REF_ARRAY)
for (dim = 0; dim < ref->u.ar.as->rank; dim++) for (dim = 0; dim < ref->u.ar.as->rank; dim++)
last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT); last = (ref->u.ar.end[dim] == NULL)
&& (ref->u.ar.type == DIMEN_ELEMENT);
if (last) if (last)
{ {
...@@ -834,8 +821,7 @@ resolve_assumed_size_actual (gfc_expr *e) ...@@ -834,8 +821,7 @@ resolve_assumed_size_actual (gfc_expr *e)
switch (e->expr_type) switch (e->expr_type)
{ {
case EXPR_VARIABLE: case EXPR_VARIABLE:
if (e->symtree if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
&& check_assumed_size_reference (e->symtree->n.sym, e))
return true; return true;
break; break;
...@@ -859,7 +845,7 @@ resolve_assumed_size_actual (gfc_expr *e) ...@@ -859,7 +845,7 @@ resolve_assumed_size_actual (gfc_expr *e)
references. */ references. */
static try static try
resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
{ {
gfc_symbol *sym; gfc_symbol *sym;
gfc_symtree *parent_st; gfc_symtree *parent_st;
...@@ -890,8 +876,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) ...@@ -890,8 +876,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
goto argument_list; goto argument_list;
} }
/* See if the expression node should really be a variable /* See if the expression node should really be a variable reference. */
reference. */
sym = e->symtree->n.sym; sym = e->symtree->n.sym;
...@@ -915,7 +900,8 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) ...@@ -915,7 +900,8 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
"actual argument", sym->name, &e->where); "actual argument", sym->name, &e->where);
} }
actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine); actual_ok = gfc_intrinsic_actual_ok (sym->name,
sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0) if (sym->attr.intrinsic && actual_ok == 0)
{ {
gfc_error ("Intrinsic '%s' at %L is not allowed as an " gfc_error ("Intrinsic '%s' at %L is not allowed as an "
...@@ -954,8 +940,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) ...@@ -954,8 +940,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
/* If all else fails, see if we have a specific intrinsic. */ /* If all else fails, see if we have a specific intrinsic. */
if (sym->attr.function if (sym->attr.function
&& sym->ts.type == BT_UNKNOWN && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
&& sym->attr.intrinsic)
{ {
gfc_intrinsic_sym *isym; gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name); isym = gfc_find_function (sym->name);
...@@ -1070,6 +1055,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) ...@@ -1070,6 +1055,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
/* Do the checks of the actual argument list that are specific to elemental /* Do the checks of the actual argument list that are specific to elemental
procedures. If called with c == NULL, we have a function, otherwise if procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */ expr == NULL, we have a subroutine. */
static try static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c) resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{ {
...@@ -1103,8 +1089,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) ...@@ -1103,8 +1089,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
else else
return SUCCESS; return SUCCESS;
} }
else if (c && c->ext.actual != NULL else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
&& c->symtree->n.sym->attr.elemental)
{ {
arg0 = c->ext.actual; arg0 = c->ext.actual;
esym = c->symtree->n.sym; esym = c->symtree->n.sym;
...@@ -1174,7 +1159,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) ...@@ -1174,7 +1159,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{ {
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS " gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an " "MISSING, it cannot be the actual argument of an "
"ELEMENTAL procedure unless there is a non-optional" "ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)", "argument with the same rank (12.4.1.5)",
arg->expr->symtree->n.sym->name, &arg->expr->where); arg->expr->symtree->n.sym->name, &arg->expr->where);
return FAILURE; return FAILURE;
...@@ -1214,7 +1199,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) ...@@ -1214,7 +1199,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
function being called, or NULL if not known. */ function being called, or NULL if not known. */
static void static void
find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual) find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
{ {
gfc_actual_arglist *ap; gfc_actual_arglist *ap;
gfc_expr *expr; gfc_expr *expr;
...@@ -1226,6 +1211,7 @@ find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual) ...@@ -1226,6 +1211,7 @@ find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
ap->expr->inline_noncopying_intrinsic = 1; ap->expr->inline_noncopying_intrinsic = 1;
} }
/* This function does the checking of references to global procedures /* This function does the checking of references to global procedures
as defined in sections 18.1 and 14.1, respectively, of the Fortran as defined in sections 18.1 and 14.1, respectively, of the Fortran
77 and 95 standards. It checks for a gsymbol for the name, making 77 and 95 standards. It checks for a gsymbol for the name, making
...@@ -1257,20 +1243,20 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) ...@@ -1257,20 +1243,20 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
gsym->used = 1; gsym->used = 1;
} }
/************* Function resolution *************/ /************* Function resolution *************/
/* Resolve a function call known to be generic. /* Resolve a function call known to be generic.
Section 14.1.2.4.1. */ Section 14.1.2.4.1. */
static match static match
resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym) resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
{ {
gfc_symbol *s; gfc_symbol *s;
if (sym->attr.generic) if (sym->attr.generic)
{ {
s = s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
if (s != NULL) if (s != NULL)
{ {
expr->value.function.name = s->name; expr->value.function.name = s->name;
...@@ -1289,7 +1275,8 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym) ...@@ -1289,7 +1275,8 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
return MATCH_YES; return MATCH_YES;
} }
/* TODO: Need to search for elemental references in generic interface */ /* TODO: Need to search for elemental references in generic
interface. */
} }
if (sym->attr.intrinsic) if (sym->attr.intrinsic)
...@@ -1300,7 +1287,7 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym) ...@@ -1300,7 +1287,7 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
static try static try
resolve_generic_f (gfc_expr * expr) resolve_generic_f (gfc_expr *expr)
{ {
gfc_symbol *sym; gfc_symbol *sym;
match m; match m;
...@@ -1339,9 +1326,9 @@ generic: ...@@ -1339,9 +1326,9 @@ generic:
if (m == MATCH_YES) if (m == MATCH_YES)
return SUCCESS; return SUCCESS;
if (m == MATCH_NO) if (m == MATCH_NO)
gfc_error gfc_error ("Generic function '%s' at %L is not consistent with a "
("Generic function '%s' at %L is not consistent with a specific " "specific intrinsic interface", expr->symtree->n.sym->name,
"intrinsic interface", expr->symtree->n.sym->name, &expr->where); &expr->where);
return FAILURE; return FAILURE;
} }
...@@ -1350,7 +1337,7 @@ generic: ...@@ -1350,7 +1337,7 @@ generic:
/* Resolve a function call known to be specific. */ /* Resolve a function call known to be specific. */
static match static match
resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr) resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{ {
match m; match m;
...@@ -1377,9 +1364,8 @@ resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr) ...@@ -1377,9 +1364,8 @@ resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
if (m == MATCH_YES) if (m == MATCH_YES)
return MATCH_YES; return MATCH_YES;
if (m == MATCH_NO) if (m == MATCH_NO)
gfc_error gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
("Function '%s' at %L is INTRINSIC but is not compatible with " "with an intrinsic", sym->name, &expr->where);
"an intrinsic", sym->name, &expr->where);
return MATCH_ERROR; return MATCH_ERROR;
} }
...@@ -1400,7 +1386,7 @@ found: ...@@ -1400,7 +1386,7 @@ found:
static try static try
resolve_specific_f (gfc_expr * expr) resolve_specific_f (gfc_expr *expr)
{ {
gfc_symbol *sym; gfc_symbol *sym;
match m; match m;
...@@ -1434,7 +1420,7 @@ resolve_specific_f (gfc_expr * expr) ...@@ -1434,7 +1420,7 @@ resolve_specific_f (gfc_expr * expr)
/* Resolve a procedure call not known to be generic nor specific. */ /* Resolve a procedure call not known to be generic nor specific. */
static try static try
resolve_unknown_f (gfc_expr * expr) resolve_unknown_f (gfc_expr *expr)
{ {
gfc_symbol *sym; gfc_symbol *sym;
gfc_typespec *ts; gfc_typespec *ts;
...@@ -1497,7 +1483,7 @@ set_type: ...@@ -1497,7 +1483,7 @@ set_type:
function is PURE, zero if not. */ function is PURE, zero if not. */
static int static int
pure_function (gfc_expr * e, const char **name) pure_function (gfc_expr *e, const char **name)
{ {
int pure; int pure;
...@@ -1534,10 +1520,10 @@ pure_function (gfc_expr * e, const char **name) ...@@ -1534,10 +1520,10 @@ pure_function (gfc_expr * e, const char **name)
to INTENT(OUT) or INTENT(INOUT). */ to INTENT(OUT) or INTENT(INOUT). */
static try static try
resolve_function (gfc_expr * expr) resolve_function (gfc_expr *expr)
{ {
gfc_actual_arglist *arg; gfc_actual_arglist *arg;
gfc_symbol * sym; gfc_symbol *sym;
const char *name; const char *name;
try t; try t;
int temp; int temp;
...@@ -1549,8 +1535,7 @@ resolve_function (gfc_expr * expr) ...@@ -1549,8 +1535,7 @@ resolve_function (gfc_expr * expr)
if (sym && sym->attr.flavor == FL_VARIABLE) if (sym && sym->attr.flavor == FL_VARIABLE)
{ {
gfc_error ("'%s' at %L is not a function", gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
sym->name, &expr->where);
return FAILURE; return FAILURE;
} }
...@@ -1588,7 +1573,7 @@ resolve_function (gfc_expr * expr) ...@@ -1588,7 +1573,7 @@ resolve_function (gfc_expr * expr)
return FAILURE; return FAILURE;
} }
/* See if function is already resolved. */ /* See if function is already resolved. */
if (expr->value.function.name != NULL) if (expr->value.function.name != NULL)
{ {
...@@ -1635,8 +1620,8 @@ resolve_function (gfc_expr * expr) ...@@ -1635,8 +1620,8 @@ resolve_function (gfc_expr * expr)
&& expr->value.function.esym && expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym)) && ! gfc_elemental (expr->value.function.esym))
{ {
gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed" gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
" in WORKSHARE construct", expr->value.function.esym->name, "in WORKSHARE construct", expr->value.function.esym->name,
&expr->where); &expr->where);
t = FAILURE; t = FAILURE;
} }
...@@ -1683,10 +1668,9 @@ resolve_function (gfc_expr * expr) ...@@ -1683,10 +1668,9 @@ resolve_function (gfc_expr * expr)
{ {
if (forall_flag) if (forall_flag)
{ {
gfc_error gfc_error ("reference to non-PURE function '%s' at %L inside a "
("reference to non-PURE function '%s' at %L inside a " "FORALL %s", name, &expr->where,
"FORALL %s", name, &expr->where, forall_flag == 2 ? forall_flag == 2 ? "mask" : "block");
"mask" : "block");
t = FAILURE; t = FAILURE;
} }
else if (gfc_pure (NULL)) else if (gfc_pure (NULL))
...@@ -1752,9 +1736,8 @@ resolve_function (gfc_expr * expr) ...@@ -1752,9 +1736,8 @@ resolve_function (gfc_expr * expr)
/************* Subroutine resolution *************/ /************* Subroutine resolution *************/
static void static void
pure_subroutine (gfc_code * c, gfc_symbol * sym) pure_subroutine (gfc_code *c, gfc_symbol *sym)
{ {
if (gfc_pure (sym)) if (gfc_pure (sym))
return; return;
...@@ -1768,7 +1751,7 @@ pure_subroutine (gfc_code * c, gfc_symbol * sym) ...@@ -1768,7 +1751,7 @@ pure_subroutine (gfc_code * c, gfc_symbol * sym)
static match static match
resolve_generic_s0 (gfc_code * c, gfc_symbol * sym) resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
{ {
gfc_symbol *s; gfc_symbol *s;
...@@ -1793,7 +1776,7 @@ resolve_generic_s0 (gfc_code * c, gfc_symbol * sym) ...@@ -1793,7 +1776,7 @@ resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
static try static try
resolve_generic_s (gfc_code * c) resolve_generic_s (gfc_code *c)
{ {
gfc_symbol *sym; gfc_symbol *sym;
match m; match m;
...@@ -1825,8 +1808,7 @@ generic: ...@@ -1825,8 +1808,7 @@ generic:
if (!gfc_intrinsic_name (sym->name, 1)) if (!gfc_intrinsic_name (sym->name, 1))
{ {
gfc_error gfc_error ("There is no specific subroutine for the generic '%s' at %L",
("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc); sym->name, &c->loc);
return FAILURE; return FAILURE;
} }
...@@ -1845,7 +1827,7 @@ generic: ...@@ -1845,7 +1827,7 @@ generic:
/* Resolve a subroutine call known to be specific. */ /* Resolve a subroutine call known to be specific. */
static match static match
resolve_specific_s0 (gfc_code * c, gfc_symbol * sym) resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{ {
match m; match m;
...@@ -1889,7 +1871,7 @@ found: ...@@ -1889,7 +1871,7 @@ found:
static try static try
resolve_specific_s (gfc_code * c) resolve_specific_s (gfc_code *c)
{ {
gfc_symbol *sym; gfc_symbol *sym;
match m; match m;
...@@ -1924,7 +1906,7 @@ resolve_specific_s (gfc_code * c) ...@@ -1924,7 +1906,7 @@ resolve_specific_s (gfc_code * c)
/* Resolve a subroutine call not known to be generic nor specific. */ /* Resolve a subroutine call not known to be generic nor specific. */
static try static try
resolve_unknown_s (gfc_code * c) resolve_unknown_s (gfc_code *c)
{ {
gfc_symbol *sym; gfc_symbol *sym;
...@@ -1963,7 +1945,7 @@ found: ...@@ -1963,7 +1945,7 @@ found:
makes things awkward. */ makes things awkward. */
static try static try
resolve_call (gfc_code * c) resolve_call (gfc_code *c)
{ {
try t; try t;
procedure_type ptype = PROC_INTRINSIC; procedure_type ptype = PROC_INTRINSIC;
...@@ -2022,7 +2004,6 @@ resolve_call (gfc_code * c) ...@@ -2022,7 +2004,6 @@ resolve_call (gfc_code * c)
/* Resume assumed_size checking. */ /* Resume assumed_size checking. */
need_full_assumed_size--; need_full_assumed_size--;
t = SUCCESS; t = SUCCESS;
if (c->resolved_sym == NULL) if (c->resolved_sym == NULL)
switch (procedure_kind (c->symtree->n.sym)) switch (procedure_kind (c->symtree->n.sym))
...@@ -2052,6 +2033,7 @@ resolve_call (gfc_code * c) ...@@ -2052,6 +2033,7 @@ resolve_call (gfc_code * c)
return t; return t;
} }
/* Compare the shapes of two arrays that have non-NULL shapes. If both /* Compare the shapes of two arrays that have non-NULL shapes. If both
op1->shape and op2->shape are non-NULL return SUCCESS if their shapes op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
match. If both op1->shape and op2->shape are non-NULL return FAILURE match. If both op1->shape and op2->shape are non-NULL return FAILURE
...@@ -2059,7 +2041,7 @@ resolve_call (gfc_code * c) ...@@ -2059,7 +2041,7 @@ resolve_call (gfc_code * c)
NULL, return SUCCESS. */ NULL, return SUCCESS. */
static try static try
compare_shapes (gfc_expr * op1, gfc_expr * op2) compare_shapes (gfc_expr *op1, gfc_expr *op2)
{ {
try t; try t;
int i; int i;
...@@ -2083,11 +2065,12 @@ compare_shapes (gfc_expr * op1, gfc_expr * op2) ...@@ -2083,11 +2065,12 @@ compare_shapes (gfc_expr * op1, gfc_expr * op2)
return t; return t;
} }
/* Resolve an operator expression node. This can involve replacing the /* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */ operation with a user defined function call. */
static try static try
resolve_operator (gfc_expr * e) resolve_operator (gfc_expr *e)
{ {
gfc_expr *op1, *op2; gfc_expr *op1, *op2;
char msg[200]; char msg[200];
...@@ -2367,7 +2350,6 @@ bad_op: ...@@ -2367,7 +2350,6 @@ bad_op:
/************** Array resolution subroutines **************/ /************** Array resolution subroutines **************/
typedef enum typedef enum
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN } { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
comparison; comparison;
...@@ -2375,7 +2357,7 @@ comparison; ...@@ -2375,7 +2357,7 @@ comparison;
/* Compare two integer expressions. */ /* Compare two integer expressions. */
static comparison static comparison
compare_bound (gfc_expr * a, gfc_expr * b) compare_bound (gfc_expr *a, gfc_expr *b)
{ {
int i; int i;
...@@ -2399,7 +2381,7 @@ compare_bound (gfc_expr * a, gfc_expr * b) ...@@ -2399,7 +2381,7 @@ compare_bound (gfc_expr * a, gfc_expr * b)
/* Compare an integer expression with an integer. */ /* Compare an integer expression with an integer. */
static comparison static comparison
compare_bound_int (gfc_expr * a, int b) compare_bound_int (gfc_expr *a, int b)
{ {
int i; int i;
...@@ -2422,7 +2404,7 @@ compare_bound_int (gfc_expr * a, int b) ...@@ -2422,7 +2404,7 @@ compare_bound_int (gfc_expr * a, int b)
/* Compare an integer expression with a mpz_t. */ /* Compare an integer expression with a mpz_t. */
static comparison static comparison
compare_bound_mpz_t (gfc_expr * a, mpz_t b) compare_bound_mpz_t (gfc_expr *a, mpz_t b)
{ {
int i; int i;
...@@ -2447,8 +2429,8 @@ compare_bound_mpz_t (gfc_expr * a, mpz_t b) ...@@ -2447,8 +2429,8 @@ compare_bound_mpz_t (gfc_expr * a, mpz_t b)
sequence if empty, and 1 otherwise. */ sequence if empty, and 1 otherwise. */
static int static int
compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end, compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
gfc_expr * stride, mpz_t last) gfc_expr *stride, mpz_t last)
{ {
mpz_t rem; mpz_t rem;
...@@ -2496,7 +2478,7 @@ compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end, ...@@ -2496,7 +2478,7 @@ compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
specification. */ specification. */
static try static try
check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{ {
mpz_t last_value; mpz_t last_value;
...@@ -2576,7 +2558,7 @@ bound: ...@@ -2576,7 +2558,7 @@ bound:
/* Compare an array reference with an array specification. */ /* Compare an array reference with an array specification. */
static try static try
compare_spec_to_ref (gfc_array_ref * ar) compare_spec_to_ref (gfc_array_ref *ar)
{ {
gfc_array_spec *as; gfc_array_spec *as;
int i; int i;
...@@ -2589,8 +2571,8 @@ compare_spec_to_ref (gfc_array_ref * ar) ...@@ -2589,8 +2571,8 @@ compare_spec_to_ref (gfc_array_ref * ar)
||*/ (ar->type == AR_SECTION ||*/ (ar->type == AR_SECTION
&& ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
{ {
gfc_error ("Rightmost upper bound of assumed size array section" gfc_error ("Rightmost upper bound of assumed size array section "
" not specified at %L", &ar->where); "not specified at %L", &ar->where);
return FAILURE; return FAILURE;
} }
...@@ -2615,7 +2597,7 @@ compare_spec_to_ref (gfc_array_ref * ar) ...@@ -2615,7 +2597,7 @@ compare_spec_to_ref (gfc_array_ref * ar)
/* Resolve one part of an array index. */ /* Resolve one part of an array index. */
try try
gfc_resolve_index (gfc_expr * index, int check_scalar) gfc_resolve_index (gfc_expr *index, int check_scalar)
{ {
gfc_typespec ts; gfc_typespec ts;
...@@ -2702,7 +2684,7 @@ gfc_resolve_dim_arg (gfc_expr *dim) ...@@ -2702,7 +2684,7 @@ gfc_resolve_dim_arg (gfc_expr *dim)
provide an additional array specification. */ provide an additional array specification. */
static void static void
find_array_spec (gfc_expr * e) find_array_spec (gfc_expr *e)
{ {
gfc_array_spec *as; gfc_array_spec *as;
gfc_component *c; gfc_component *c;
...@@ -2762,7 +2744,7 @@ find_array_spec (gfc_expr * e) ...@@ -2762,7 +2744,7 @@ find_array_spec (gfc_expr * e)
/* Resolve an array reference. */ /* Resolve an array reference. */
static try static try
resolve_array_ref (gfc_array_ref * ar) resolve_array_ref (gfc_array_ref *ar)
{ {
int i, check_scalar; int i, check_scalar;
gfc_expr *e; gfc_expr *e;
...@@ -2823,9 +2805,8 @@ resolve_array_ref (gfc_array_ref * ar) ...@@ -2823,9 +2805,8 @@ resolve_array_ref (gfc_array_ref * ar)
static try static try
resolve_substring (gfc_ref * ref) resolve_substring (gfc_ref *ref)
{ {
if (ref->u.ss.start != NULL) if (ref->u.ss.start != NULL)
{ {
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE) if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
...@@ -2892,7 +2873,7 @@ resolve_substring (gfc_ref * ref) ...@@ -2892,7 +2873,7 @@ resolve_substring (gfc_ref * ref)
/* Resolve subtype references. */ /* Resolve subtype references. */
static try static try
resolve_ref (gfc_expr * expr) resolve_ref (gfc_expr *expr)
{ {
int current_part_dimension, n_components, seen_part_dimension; int current_part_dimension, n_components, seen_part_dimension;
gfc_ref *ref; gfc_ref *ref;
...@@ -2953,18 +2934,16 @@ resolve_ref (gfc_expr * expr) ...@@ -2953,18 +2934,16 @@ resolve_ref (gfc_expr * expr)
{ {
if (ref->u.c.component->pointer) if (ref->u.c.component->pointer)
{ {
gfc_error gfc_error ("Component to the right of a part reference "
("Component to the right of a part reference with nonzero " "with nonzero rank must not have the POINTER "
"rank must not have the POINTER attribute at %L", "attribute at %L", &expr->where);
&expr->where);
return FAILURE; return FAILURE;
} }
else if (ref->u.c.component->allocatable) else if (ref->u.c.component->allocatable)
{ {
gfc_error gfc_error ("Component to the right of a part reference "
("Component to the right of a part reference with nonzero " "with nonzero rank must not have the ALLOCATABLE "
"rank must not have the ALLOCATABLE attribute at %L", "attribute at %L", &expr->where);
&expr->where);
return FAILURE; return FAILURE;
} }
} }
...@@ -2981,7 +2960,6 @@ resolve_ref (gfc_expr * expr) ...@@ -2981,7 +2960,6 @@ resolve_ref (gfc_expr * expr)
&& current_part_dimension && current_part_dimension
&& seen_part_dimension) && seen_part_dimension)
{ {
gfc_error ("Two or more part references with nonzero rank must " gfc_error ("Two or more part references with nonzero rank must "
"not be specified at %L", &expr->where); "not be specified at %L", &expr->where);
return FAILURE; return FAILURE;
...@@ -3005,7 +2983,7 @@ resolve_ref (gfc_expr * expr) ...@@ -3005,7 +2983,7 @@ resolve_ref (gfc_expr * expr)
Leaves the shape array NULL if it is not possible to determine the shape. */ Leaves the shape array NULL if it is not possible to determine the shape. */
static void static void
expression_shape (gfc_expr * e) expression_shape (gfc_expr *e)
{ {
mpz_t array[GFC_MAX_DIMENSIONS]; mpz_t array[GFC_MAX_DIMENSIONS];
int i; int i;
...@@ -3033,7 +3011,7 @@ fail: ...@@ -3033,7 +3011,7 @@ fail:
examining the base symbol and any reference structures it may have. */ examining the base symbol and any reference structures it may have. */
static void static void
expression_rank (gfc_expr * e) expression_rank (gfc_expr *e)
{ {
gfc_ref *ref; gfc_ref *ref;
int i, rank; int i, rank;
...@@ -3093,7 +3071,7 @@ done: ...@@ -3093,7 +3071,7 @@ done:
/* Resolve a variable expression. */ /* Resolve a variable expression. */
static try static try
resolve_variable (gfc_expr * e) resolve_variable (gfc_expr *e)
{ {
gfc_symbol *sym; gfc_symbol *sym;
try t; try t;
...@@ -3201,7 +3179,7 @@ resolve_variable (gfc_expr * e) ...@@ -3201,7 +3179,7 @@ resolve_variable (gfc_expr * e)
for overloaded types and unresolved function references are resolved. */ for overloaded types and unresolved function references are resolved. */
try try
gfc_resolve_expr (gfc_expr * e) gfc_resolve_expr (gfc_expr *e)
{ {
try t; try t;
...@@ -3246,8 +3224,9 @@ gfc_resolve_expr (gfc_expr * e) ...@@ -3246,8 +3224,9 @@ gfc_resolve_expr (gfc_expr * e)
gfc_expand_constructor (e); gfc_expand_constructor (e);
} }
/* This provides the opportunity for the length of constructors with character /* This provides the opportunity for the length of constructors with
valued function elements to propogate the string length to the expression. */ character valued function elements to propogate the string length
to the expression. */
if (e->ts.type == BT_CHARACTER) if (e->ts.type == BT_CHARACTER)
gfc_resolve_character_array_constructor (e); gfc_resolve_character_array_constructor (e);
...@@ -3277,8 +3256,8 @@ gfc_resolve_expr (gfc_expr * e) ...@@ -3277,8 +3256,8 @@ gfc_resolve_expr (gfc_expr * e)
INTEGER or (optionally) REAL type. */ INTEGER or (optionally) REAL type. */
static try static try
gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
const char * name_msgid) const char *name_msgid)
{ {
if (gfc_resolve_expr (expr) == FAILURE) if (gfc_resolve_expr (expr) == FAILURE)
return FAILURE; return FAILURE;
...@@ -3307,12 +3286,11 @@ gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, ...@@ -3307,12 +3286,11 @@ gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
false allow only INTEGER type iterators, otherwise allow REAL types. */ false allow only INTEGER type iterators, otherwise allow REAL types. */
try try
gfc_resolve_iterator (gfc_iterator * iter, bool real_ok) gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
{ {
if (iter->var->ts.type == BT_REAL) if (iter->var->ts.type == BT_REAL)
gfc_notify_std (GFC_STD_F95_DEL, gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: REAL DO loop iterator at %L",
"Obsolete: REAL DO loop iterator at %L",
&iter->var->where); &iter->var->where);
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable") if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
...@@ -3373,9 +3351,8 @@ gfc_resolve_iterator (gfc_iterator * iter, bool real_ok) ...@@ -3373,9 +3351,8 @@ gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
INTEGERs, and if stride is a constant it must be nonzero. */ INTEGERs, and if stride is a constant it must be nonzero. */
static void static void
resolve_forall_iterators (gfc_forall_iterator * iter) resolve_forall_iterators (gfc_forall_iterator *iter)
{ {
while (iter) while (iter)
{ {
if (gfc_resolve_expr (iter->var) == SUCCESS if (gfc_resolve_expr (iter->var) == SUCCESS
...@@ -3421,7 +3398,7 @@ resolve_forall_iterators (gfc_forall_iterator * iter) ...@@ -3421,7 +3398,7 @@ resolve_forall_iterators (gfc_forall_iterator * iter)
Returns zero if no pointer components are found, nonzero otherwise. */ Returns zero if no pointer components are found, nonzero otherwise. */
static int static int
derived_pointer (gfc_symbol * sym) derived_pointer (gfc_symbol *sym)
{ {
gfc_component *c; gfc_component *c;
...@@ -3465,7 +3442,7 @@ derived_inaccessible (gfc_symbol *sym) ...@@ -3465,7 +3442,7 @@ derived_inaccessible (gfc_symbol *sym)
a pointer or a full array. */ a pointer or a full array. */
static try static try
resolve_deallocate_expr (gfc_expr * e) resolve_deallocate_expr (gfc_expr *e)
{ {
symbol_attribute attr; symbol_attribute attr;
int allocatable, pointer, check_intent_in; int allocatable, pointer, check_intent_in;
...@@ -3526,6 +3503,7 @@ resolve_deallocate_expr (gfc_expr * e) ...@@ -3526,6 +3503,7 @@ resolve_deallocate_expr (gfc_expr * e)
return SUCCESS; return SUCCESS;
} }
/* Returns true if the expression e contains a reference the symbol sym. */ /* Returns true if the expression e contains a reference the symbol sym. */
static bool static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
...@@ -3586,13 +3564,19 @@ find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) ...@@ -3586,13 +3564,19 @@ find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
if (ref->u.c.component->ts.type == BT_CHARACTER if (ref->u.c.component->ts.type == BT_CHARACTER
&& ref->u.c.component->ts.cl->length->expr_type && ref->u.c.component->ts.cl->length->expr_type
!= EXPR_CONSTANT) != EXPR_CONSTANT)
rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length); rv = rv
|| find_sym_in_expr (sym,
ref->u.c.component->ts.cl->length);
if (ref->u.c.component->as) if (ref->u.c.component->as)
for (i = 0; i < ref->u.c.component->as->rank; i++) for (i = 0; i < ref->u.c.component->as->rank; i++)
{ {
rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]); rv = rv
rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]); || find_sym_in_expr (sym,
ref->u.c.component->as->lower[i]);
rv = rv
|| find_sym_in_expr (sym,
ref->u.c.component->as->upper[i]);
} }
break; break;
} }
...@@ -3608,7 +3592,7 @@ find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) ...@@ -3608,7 +3592,7 @@ find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
components that need nullification.) */ components that need nullification.) */
static gfc_expr * static gfc_expr *
expr_to_initialize (gfc_expr * e) expr_to_initialize (gfc_expr *e)
{ {
gfc_expr *result; gfc_expr *result;
gfc_ref *ref; gfc_ref *ref;
...@@ -3638,7 +3622,7 @@ expr_to_initialize (gfc_expr * e) ...@@ -3638,7 +3622,7 @@ expr_to_initialize (gfc_expr * e)
have a trailing array reference that gives the size of the array. */ have a trailing array reference that gives the size of the array. */
static try static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code) resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{ {
int i, pointer, allocatable, dimension, check_intent_in; int i, pointer, allocatable, dimension, check_intent_in;
symbol_attribute attr; symbol_attribute attr;
...@@ -3668,11 +3652,9 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code) ...@@ -3668,11 +3652,9 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
if (e->expr_type != EXPR_VARIABLE) if (e->expr_type != EXPR_VARIABLE)
{ {
allocatable = 0; allocatable = 0;
attr = gfc_expr_attr (e); attr = gfc_expr_attr (e);
pointer = attr.pointer; pointer = attr.pointer;
dimension = attr.dimension; dimension = attr.dimension;
} }
else else
{ {
...@@ -3819,7 +3801,7 @@ check_symbols: ...@@ -3819,7 +3801,7 @@ check_symbols:
There are nine situations to check. */ There are nine situations to check. */
static int static int
compare_cases (const gfc_case * op1, const gfc_case * op2) compare_cases (const gfc_case *op1, const gfc_case *op2)
{ {
int retval; int retval;
...@@ -3869,7 +3851,7 @@ compare_cases (const gfc_case * op1, const gfc_case * op2) ...@@ -3869,7 +3851,7 @@ compare_cases (const gfc_case * op1, const gfc_case * op2)
overlap, or NULL otherwise. */ overlap, or NULL otherwise. */
static gfc_case * static gfc_case *
check_case_overlap (gfc_case * list) check_case_overlap (gfc_case *list)
{ {
gfc_case *p, *q, *e, *tail; gfc_case *p, *q, *e, *tail;
int insize, nmerges, psize, qsize, cmp, overlap_seen; int insize, nmerges, psize, qsize, cmp, overlap_seen;
...@@ -3916,7 +3898,6 @@ check_case_overlap (gfc_case * list) ...@@ -3916,7 +3898,6 @@ check_case_overlap (gfc_case * list)
/* Now we have two lists. Merge them! */ /* Now we have two lists. Merge them! */
while (psize > 0 || (qsize > 0 && q != NULL)) while (psize > 0 || (qsize > 0 && q != NULL))
{ {
/* See from which the next case to merge comes from. */ /* See from which the next case to merge comes from. */
if (psize == 0) if (psize == 0)
{ {
...@@ -4002,7 +3983,7 @@ check_case_overlap (gfc_case * list) ...@@ -4002,7 +3983,7 @@ check_case_overlap (gfc_case * list)
type. Return FAILURE if anything is wrong. */ type. Return FAILURE if anything is wrong. */
static try static try
validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr) validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
{ {
if (e == NULL) return SUCCESS; if (e == NULL) return SUCCESS;
...@@ -4061,7 +4042,7 @@ validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr) ...@@ -4061,7 +4042,7 @@ validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
expression. */ expression. */
static void static void
resolve_select (gfc_code * code) resolve_select (gfc_code *code)
{ {
gfc_code *body; gfc_code *body;
gfc_expr *case_expr; gfc_expr *case_expr;
...@@ -4076,8 +4057,7 @@ resolve_select (gfc_code * code) ...@@ -4076,8 +4057,7 @@ resolve_select (gfc_code * code)
{ {
/* This was actually a computed GOTO statement. */ /* This was actually a computed GOTO statement. */
case_expr = code->expr2; case_expr = code->expr2;
if (case_expr->ts.type != BT_INTEGER if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
|| case_expr->rank != 0)
gfc_error ("Selection expression in computed GOTO statement " gfc_error ("Selection expression in computed GOTO statement "
"at %L must be a scalar integer expression", "at %L must be a scalar integer expression",
&case_expr->where); &case_expr->where);
...@@ -4196,9 +4176,8 @@ resolve_select (gfc_code * code) ...@@ -4196,9 +4176,8 @@ resolve_select (gfc_code * code)
&& ((cp->low == NULL || cp->high == NULL) && ((cp->low == NULL || cp->high == NULL)
|| cp->low != cp->high)) || cp->low != cp->high))
{ {
gfc_error gfc_error ("Logical range in CASE statement at %L is not "
("Logical range in CASE statement at %L is not allowed", "allowed", &cp->low->where);
&cp->low->where);
t = FAILURE; t = FAILURE;
break; break;
} }
...@@ -4338,7 +4317,7 @@ resolve_select (gfc_code * code) ...@@ -4338,7 +4317,7 @@ resolve_select (gfc_code * code)
-- we're not trying to transfer a whole assumed size array. */ -- we're not trying to transfer a whole assumed size array. */
static void static void
resolve_transfer (gfc_code * code) resolve_transfer (gfc_code *code)
{ {
gfc_typespec *ts; gfc_typespec *ts;
gfc_symbol *sym; gfc_symbol *sym;
...@@ -4347,8 +4326,7 @@ resolve_transfer (gfc_code * code) ...@@ -4347,8 +4326,7 @@ resolve_transfer (gfc_code * code)
exp = code->expr; exp = code->expr;
if (exp->expr_type != EXPR_VARIABLE if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
&& exp->expr_type != EXPR_FUNCTION)
return; return;
sym = exp->symtree->n.sym; sym = exp->symtree->n.sym;
...@@ -4401,7 +4379,7 @@ resolve_transfer (gfc_code * code) ...@@ -4401,7 +4379,7 @@ resolve_transfer (gfc_code * code)
The code node described where the branch is located. */ The code node described where the branch is located. */
static void static void
resolve_branch (gfc_st_label * label, gfc_code * code) resolve_branch (gfc_st_label *label, gfc_code *code)
{ {
gfc_code *block, *found; gfc_code *block, *found;
code_stack *stack; code_stack *stack;
...@@ -4463,9 +4441,8 @@ resolve_branch (gfc_st_label * label, gfc_code * code) ...@@ -4463,9 +4441,8 @@ resolve_branch (gfc_st_label * label, gfc_code * code)
/* The label is not in an enclosing block, so illegal. This was /* The label is not in an enclosing block, so illegal. This was
allowed in Fortran 66, so we allow it as extension. We also allowed in Fortran 66, so we allow it as extension. We also
forego further checks if we run into this. */ forego further checks if we run into this. */
gfc_notify_std (GFC_STD_LEGACY, gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
"Label at %L is not in the same block as the " "as the GOTO statement at %L", &lp->where, &code->loc);
"GOTO statement at %L", &lp->where, &code->loc);
return; return;
} }
...@@ -4479,9 +4456,8 @@ resolve_branch (gfc_st_label * label, gfc_code * code) ...@@ -4479,9 +4456,8 @@ resolve_branch (gfc_st_label * label, gfc_code * code)
break; break;
if (stack == NULL) if (stack == NULL)
gfc_notify_std (GFC_STD_F95_DEL, gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to END "
"Obsolete: GOTO at %L jumps to END of construct at %L", "of construct at %L", &code->loc, &found->loc);
&code->loc, &found->loc);
} }
} }
...@@ -4519,7 +4495,7 @@ ignore: ...@@ -4519,7 +4495,7 @@ ignore:
result = SUCCESS; result = SUCCESS;
over: over:
for (i--; i>=0; i--) for (i--; i >= 0; i--)
{ {
mpz_clear (shape[i]); mpz_clear (shape[i]);
mpz_clear (shape2[i]); mpz_clear (shape2[i]);
...@@ -4754,7 +4730,9 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) ...@@ -4754,7 +4730,9 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
/* Resolve WHERE statement in FORALL construct. */ /* Resolve WHERE statement in FORALL construct. */
static void static void
gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
gfc_expr **var_expr)
{
gfc_code *cblock; gfc_code *cblock;
gfc_code *cnext; gfc_code *cnext;
...@@ -4913,7 +4891,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) ...@@ -4913,7 +4891,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
static void resolve_code (gfc_code *, gfc_namespace *); static void resolve_code (gfc_code *, gfc_namespace *);
void void
gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns) gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{ {
try t; try t;
...@@ -4928,18 +4906,15 @@ gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns) ...@@ -4928,18 +4906,15 @@ gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
case EXEC_IF: case EXEC_IF:
if (t == SUCCESS && b->expr != NULL if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0)) && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
gfc_error gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
("IF clause at %L requires a scalar LOGICAL expression",
&b->expr->where); &b->expr->where);
break; break;
case EXEC_WHERE: case EXEC_WHERE:
if (t == SUCCESS if (t == SUCCESS
&& b->expr != NULL && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
|| b->expr->rank == 0)) gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
gfc_error
("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
&b->expr->where); &b->expr->where);
break; break;
...@@ -4983,7 +4958,7 @@ gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns) ...@@ -4983,7 +4958,7 @@ gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
code block. */ code block. */
static void static void
resolve_code (gfc_code * code, gfc_namespace * ns) resolve_code (gfc_code *code, gfc_namespace *ns)
{ {
int omp_workshare_save; int omp_workshare_save;
int forall_save; int forall_save;
...@@ -5069,11 +5044,11 @@ resolve_code (gfc_code * code, gfc_namespace * ns) ...@@ -5069,11 +5044,11 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
if (code->expr != NULL) if (code->expr != NULL)
{ {
if (code->expr->ts.type != BT_INTEGER) if (code->expr->ts.type != BT_INTEGER)
gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER " gfc_error ("ASSIGNED GOTO statement at %L requires an "
"variable", &code->expr->where); "INTEGER variable", &code->expr->where);
else if (code->expr->symtree->n.sym->attr.assign != 1) else if (code->expr->symtree->n.sym->attr.assign != 1)
gfc_error ("Variable '%s' has not been assigned a target label " gfc_error ("Variable '%s' has not been assigned a target "
"at %L", code->expr->symtree->n.sym->name, "label at %L", code->expr->symtree->n.sym->name,
&code->expr->where); &code->expr->where);
} }
else else
...@@ -5121,30 +5096,31 @@ resolve_code (gfc_code * code, gfc_namespace * ns) ...@@ -5121,30 +5096,31 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
else if (code->expr2->ts.cl != NULL else if (code->expr2->ts.cl != NULL
&& code->expr2->ts.cl->length != NULL && code->expr2->ts.cl->length != NULL
&& code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT) && code->expr2->ts.cl->length->expr_type
== EXPR_CONSTANT)
rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer); rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen) if (rlen && llen && rlen > llen)
gfc_warning_now ("rhs of CHARACTER assignment at %L will " gfc_warning_now ("rhs of CHARACTER assignment at %L will be "
"be truncated (%d/%d)", &code->loc, rlen, llen); "truncated (%d/%d)", &code->loc, rlen, llen);
} }
if (gfc_pure (NULL)) if (gfc_pure (NULL))
{ {
if (gfc_impure_variable (code->expr->symtree->n.sym)) if (gfc_impure_variable (code->expr->symtree->n.sym))
{ {
gfc_error gfc_error ("Cannot assign to variable '%s' in PURE "
("Cannot assign to variable '%s' in PURE procedure at %L", "procedure at %L",
code->expr->symtree->n.sym->name, &code->expr->where); code->expr->symtree->n.sym->name,
&code->expr->where);
break; break;
} }
if (code->expr2->ts.type == BT_DERIVED if (code->expr2->ts.type == BT_DERIVED
&& derived_pointer (code->expr2->ts.derived)) && derived_pointer (code->expr2->ts.derived))
{ {
gfc_error gfc_error ("Right side of assignment at %L is a derived "
("Right side of assignment at %L is a derived type " "type containing a POINTER in a PURE procedure",
"containing a POINTER in a PURE procedure",
&code->expr2->where); &code->expr2->where);
break; break;
} }
...@@ -5304,9 +5280,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns) ...@@ -5304,9 +5280,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
resolve_forall_iterators (code->ext.forall_iterator); resolve_forall_iterators (code->ext.forall_iterator);
if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL) if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
gfc_error gfc_error ("FORALL mask clause at %L requires a LOGICAL "
("FORALL mask clause at %L requires a LOGICAL expression", "expression", &code->expr->where);
&code->expr->where);
break; break;
case EXEC_OMP_ATOMIC: case EXEC_OMP_ATOMIC:
...@@ -5345,9 +5320,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns) ...@@ -5345,9 +5320,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
the variable. */ the variable. */
static void static void
resolve_values (gfc_symbol * sym) resolve_values (gfc_symbol *sym)
{ {
if (sym->value == NULL) if (sym->value == NULL)
return; return;
...@@ -5361,7 +5335,7 @@ resolve_values (gfc_symbol * sym) ...@@ -5361,7 +5335,7 @@ resolve_values (gfc_symbol * sym)
/* Resolve an index expression. */ /* Resolve an index expression. */
static try static try
resolve_index_expr (gfc_expr * e) resolve_index_expr (gfc_expr *e)
{ {
if (gfc_resolve_expr (e) == FAILURE) if (gfc_resolve_expr (e) == FAILURE)
return FAILURE; return FAILURE;
...@@ -5537,6 +5511,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) ...@@ -5537,6 +5511,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return SUCCESS; return SUCCESS;
} }
/* Resolve symbols with flavor variable. */ /* Resolve symbols with flavor variable. */
static try static try
...@@ -5546,7 +5521,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) ...@@ -5546,7 +5521,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
int i; int i;
gfc_expr *e; gfc_expr *e;
gfc_expr *constructor_expr; gfc_expr *constructor_expr;
const char * auto_save_msg; const char *auto_save_msg;
auto_save_msg = "automatic object '%s' at %L cannot have the " auto_save_msg = "automatic object '%s' at %L cannot have the "
"SAVE attribute"; "SAVE attribute";
...@@ -5564,7 +5539,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) ...@@ -5564,7 +5539,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
&& !sym->attr.pointer && !sym->attr.pointer
&& is_non_constant_shape_array (sym)) && is_non_constant_shape_array (sym))
{ {
/* The shape of a main program or module array needs to be constant. */ /* The shape of a main program or module array needs to be
constant. */
if (sym->ns->proc_name if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE && (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)) || sym->ns->proc_name->attr.is_main_program))
...@@ -5742,7 +5718,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -5742,7 +5718,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{ {
gfc_error ("Automatic character length function '%s' at %L must " gfc_error ("Automatic character length function '%s' at %L must "
"have an explicit interface", sym->name, &sym->declared_at); "have an explicit interface", sym->name,
&sym->declared_at);
return FAILURE; return FAILURE;
} }
} }
...@@ -5761,7 +5738,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -5761,7 +5738,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (arg->sym if (arg->sym
&& arg->sym->ts.type == BT_DERIVED && arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc && !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access(arg->sym->ts.derived->attr.access, && !gfc_check_access (arg->sym->ts.derived->attr.access,
arg->sym->ts.derived->ns->default_access)) arg->sym->ts.derived->ns->default_access))
{ {
gfc_error_now ("'%s' is of a PRIVATE type and cannot be " gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
...@@ -5864,9 +5841,9 @@ resolve_fl_derived (gfc_symbol *sym) ...@@ -5864,9 +5841,9 @@ resolve_fl_derived (gfc_symbol *sym)
if (c->ts.type == BT_DERIVED if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE && sym->component_access != ACCESS_PRIVATE
&& gfc_check_access(sym->attr.access, sym->ns->default_access) && gfc_check_access (sym->attr.access, sym->ns->default_access)
&& !c->ts.derived->attr.use_assoc && !c->ts.derived->attr.use_assoc
&& !gfc_check_access(c->ts.derived->attr.access, && !gfc_check_access (c->ts.derived->attr.access,
c->ts.derived->ns->default_access)) c->ts.derived->ns->default_access))
{ {
gfc_error ("The component '%s' is a PRIVATE type and cannot be " gfc_error ("The component '%s' is a PRIVATE type and cannot be "
...@@ -6019,8 +5996,7 @@ resolve_fl_parameter (gfc_symbol *sym) ...@@ -6019,8 +5996,7 @@ resolve_fl_parameter (gfc_symbol *sym)
matches the implicit type, since PARAMETER statements can precede matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */ IMPLICIT statements. */
if (sym->attr.implicit_type if (sym->attr.implicit_type
&& !gfc_compare_types (&sym->ts, && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
gfc_get_default_type (sym, sym->ns)))
{ {
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a " gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at); "later IMPLICIT type", sym->name, &sym->declared_at);
...@@ -6046,7 +6022,7 @@ resolve_fl_parameter (gfc_symbol *sym) ...@@ -6046,7 +6022,7 @@ resolve_fl_parameter (gfc_symbol *sym)
of thing commonly happens for symbols in module. */ of thing commonly happens for symbols in module. */
static void static void
resolve_symbol (gfc_symbol * sym) resolve_symbol (gfc_symbol *sym)
{ {
/* Zero if we are checking a formal namespace. */ /* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1; static int formal_ns_flag = 1;
...@@ -6148,8 +6124,7 @@ resolve_symbol (gfc_symbol * sym) ...@@ -6148,8 +6124,7 @@ resolve_symbol (gfc_symbol * sym)
until resolution time. */ until resolution time. */
if (!sym->attr.dummy if (!sym->attr.dummy
&& (sym->attr.optional && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
|| sym->attr.intent != INTENT_UNKNOWN))
{ {
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return; return;
...@@ -6162,7 +6137,6 @@ resolve_symbol (gfc_symbol * sym) ...@@ -6162,7 +6137,6 @@ resolve_symbol (gfc_symbol * sym)
return; return;
} }
/* If a derived type symbol has reached this point, without its /* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most type being declared, we have an error. Notice that most
conditions that produce undefined derived types have already conditions that produce undefined derived types have already
...@@ -6171,8 +6145,7 @@ resolve_symbol (gfc_symbol * sym) ...@@ -6171,8 +6145,7 @@ resolve_symbol (gfc_symbol * sym)
the type is not declared in the scope of the implicit the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */ and to prevent an ICE. */
if (sym->ts.type == BT_DERIVED if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
&& sym->ts.derived->components == NULL)
{ {
gfc_error ("The derived type '%s' at %L is of type '%s', " gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name, "which has not been defined", sym->name,
...@@ -6229,8 +6202,8 @@ resolve_symbol (gfc_symbol * sym) ...@@ -6229,8 +6202,8 @@ resolve_symbol (gfc_symbol * sym)
/* Make sure that intrinsic exist */ /* Make sure that intrinsic exist */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0) && !gfc_intrinsic_name(sym->name, 0)
&& ! gfc_intrinsic_name(sym->name, 1)) && !gfc_intrinsic_name(sym->name, 1))
gfc_error("Intrinsic at %L does not exist", &sym->declared_at); gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
/* Resolve array specifier. Check as well some constraints /* Resolve array specifier. Check as well some constraints
...@@ -6281,14 +6254,12 @@ resolve_symbol (gfc_symbol * sym) ...@@ -6281,14 +6254,12 @@ resolve_symbol (gfc_symbol * sym)
if ((!a->save && !a->dummy && !a->pointer if ((!a->save && !a->dummy && !a->pointer
&& !a->in_common && !a->use_assoc && !a->in_common && !a->use_assoc
&& !(a->function && sym != sym->result)) && !(a->function && sym != sym->result))
|| || (a->dummy && a->intent == INTENT_OUT))
(a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym); apply_default_init (sym);
} }
} }
/************* Resolve DATA statements *************/ /************* Resolve DATA statements *************/
static struct static struct
...@@ -6318,7 +6289,7 @@ next_data_value (void) ...@@ -6318,7 +6289,7 @@ next_data_value (void)
static try static try
check_data_variable (gfc_data_variable * var, locus * where) check_data_variable (gfc_data_variable *var, locus *where)
{ {
gfc_expr *e; gfc_expr *e;
mpz_t size; mpz_t size;
...@@ -6476,7 +6447,7 @@ static try traverse_data_var (gfc_data_variable *, locus *); ...@@ -6476,7 +6447,7 @@ static try traverse_data_var (gfc_data_variable *, locus *);
/* Iterate over a list of elements in a DATA statement. */ /* Iterate over a list of elements in a DATA statement. */
static try static try
traverse_data_list (gfc_data_variable * var, locus * where) traverse_data_list (gfc_data_variable *var, locus *where)
{ {
mpz_t trip; mpz_t trip;
iterator_stack frame; iterator_stack frame;
...@@ -6492,24 +6463,21 @@ traverse_data_list (gfc_data_variable * var, locus * where) ...@@ -6492,24 +6463,21 @@ traverse_data_list (gfc_data_variable * var, locus * where)
if (gfc_simplify_expr (start, 1) == FAILURE if (gfc_simplify_expr (start, 1) == FAILURE
|| start->expr_type != EXPR_CONSTANT) || start->expr_type != EXPR_CONSTANT)
{ {
gfc_error ("iterator start at %L does not simplify", gfc_error ("iterator start at %L does not simplify", &start->where);
&start->where);
retval = FAILURE; retval = FAILURE;
goto cleanup; goto cleanup;
} }
if (gfc_simplify_expr (end, 1) == FAILURE if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT) || end->expr_type != EXPR_CONSTANT)
{ {
gfc_error ("iterator end at %L does not simplify", gfc_error ("iterator end at %L does not simplify", &end->where);
&end->where);
retval = FAILURE; retval = FAILURE;
goto cleanup; goto cleanup;
} }
if (gfc_simplify_expr (step, 1) == FAILURE if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT) || step->expr_type != EXPR_CONSTANT)
{ {
gfc_error ("iterator step at %L does not simplify", gfc_error ("iterator step at %L does not simplify", &step->where);
&step->where);
retval = FAILURE; retval = FAILURE;
goto cleanup; goto cleanup;
} }
...@@ -6565,7 +6533,7 @@ cleanup: ...@@ -6565,7 +6533,7 @@ cleanup:
/* Type resolve variables in the variable list of a DATA statement. */ /* Type resolve variables in the variable list of a DATA statement. */
static try static try
traverse_data_var (gfc_data_variable * var, locus * where) traverse_data_var (gfc_data_variable *var, locus *where)
{ {
try t; try t;
...@@ -6589,7 +6557,7 @@ traverse_data_var (gfc_data_variable * var, locus * where) ...@@ -6589,7 +6557,7 @@ traverse_data_var (gfc_data_variable * var, locus * where)
only be resolved once. */ only be resolved once. */
static try static try
resolve_data_variables (gfc_data_variable * d) resolve_data_variables (gfc_data_variable *d)
{ {
for (; d; d = d->next) for (; d; d = d->next)
{ {
...@@ -6637,11 +6605,11 @@ resolve_data (gfc_data * d) ...@@ -6637,11 +6605,11 @@ resolve_data (gfc_data * d)
/* Determines if a variable is not 'pure', ie not assignable within a pure /* Determines if a variable is not 'pure', ie not assignable within a pure
procedure. Returns zero if assignment is OK, nonzero if there is a problem. procedure. Returns zero if assignment is OK, nonzero if there is a
*/ problem. */
int int
gfc_impure_variable (gfc_symbol * sym) gfc_impure_variable (gfc_symbol *sym)
{ {
if (sym->attr.use_assoc || sym->attr.in_common) if (sym->attr.use_assoc || sym->attr.in_common)
return 1; return 1;
...@@ -6659,7 +6627,7 @@ gfc_impure_variable (gfc_symbol * sym) ...@@ -6659,7 +6627,7 @@ gfc_impure_variable (gfc_symbol * sym)
symbol of the current procedure. */ symbol of the current procedure. */
int int
gfc_pure (gfc_symbol * sym) gfc_pure (gfc_symbol *sym)
{ {
symbol_attribute attr; symbol_attribute attr;
...@@ -6677,7 +6645,7 @@ gfc_pure (gfc_symbol * sym) ...@@ -6677,7 +6645,7 @@ gfc_pure (gfc_symbol * sym)
/* Test whether the current procedure is elemental or not. */ /* Test whether the current procedure is elemental or not. */
int int
gfc_elemental (gfc_symbol * sym) gfc_elemental (gfc_symbol *sym)
{ {
symbol_attribute attr; symbol_attribute attr;
...@@ -6694,7 +6662,7 @@ gfc_elemental (gfc_symbol * sym) ...@@ -6694,7 +6662,7 @@ gfc_elemental (gfc_symbol * sym)
/* Warn about unused labels. */ /* Warn about unused labels. */
static void static void
warn_unused_fortran_label (gfc_st_label * label) warn_unused_fortran_label (gfc_st_label *label)
{ {
if (label == NULL) if (label == NULL)
return; return;
...@@ -6798,7 +6766,8 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) ...@@ -6798,7 +6766,8 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
if (!derived->attr.sequence) if (!derived->attr.sequence)
{ {
gfc_error ("Derived type variable '%s' at %L must have SEQUENCE " gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
"attribute to be an EQUIVALENCE object", sym->name, &e->where); "attribute to be an EQUIVALENCE object", sym->name,
&e->where);
return FAILURE; return FAILURE;
} }
...@@ -6806,29 +6775,33 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) ...@@ -6806,29 +6775,33 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
if (derived->attr.alloc_comp) if (derived->attr.alloc_comp)
{ {
gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE " gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
"components to be an EQUIVALENCE object",sym->name, &e->where); "components to be an EQUIVALENCE object",sym->name,
&e->where);
return FAILURE; return FAILURE;
} }
for (; c ; c = c->next) for (; c ; c = c->next)
{ {
d = c->ts.derived; d = c->ts.derived;
if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE)) if (d
&& (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
return FAILURE; return FAILURE;
/* Shall not be an object of sequence derived type containing a pointer /* Shall not be an object of sequence derived type containing a pointer
in the structure. */ in the structure. */
if (c->pointer) if (c->pointer)
{ {
gfc_error ("Derived type variable '%s' at %L with pointer component(s) " gfc_error ("Derived type variable '%s' at %L with pointer "
"cannot be an EQUIVALENCE object", sym->name, &e->where); "component(s) cannot be an EQUIVALENCE object",
sym->name, &e->where);
return FAILURE; return FAILURE;
} }
if (c->initializer) if (c->initializer)
{ {
gfc_error ("Derived type variable '%s' at %L with default initializer " gfc_error ("Derived type variable '%s' at %L with default "
"cannot be an EQUIVALENCE object", sym->name, &e->where); "initializer cannot be an EQUIVALENCE object",
sym->name, &e->where);
return FAILURE; return FAILURE;
} }
} }
...@@ -7016,10 +6989,10 @@ resolve_equivalence (gfc_equiv *eq) ...@@ -7016,10 +6989,10 @@ resolve_equivalence (gfc_equiv *eq)
"statement at %L with different type objects"; "statement at %L with different type objects";
if ((object ==2 if ((object ==2
&& last_eq_type == SEQ_MIXED && last_eq_type == SEQ_MIXED
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
last_where) == FAILURE) == FAILURE)
|| (eq_type == SEQ_MIXED || (eq_type == SEQ_MIXED
&& gfc_notify_std (GFC_STD_GNU, msg,sym->name, && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
&e->where) == FAILURE)) &e->where) == FAILURE))
continue; continue;
...@@ -7097,7 +7070,7 @@ resolve_equivalence (gfc_equiv *eq) ...@@ -7097,7 +7070,7 @@ resolve_equivalence (gfc_equiv *eq)
/* Resolve function and ENTRY types, issue diagnostics if needed. */ /* Resolve function and ENTRY types, issue diagnostics if needed. */
static void static void
resolve_fntype (gfc_namespace * ns) resolve_fntype (gfc_namespace *ns)
{ {
gfc_entry_list *el; gfc_entry_list *el;
gfc_symbol *sym; gfc_symbol *sym;
...@@ -7163,7 +7136,7 @@ resolve_fntype (gfc_namespace * ns) ...@@ -7163,7 +7136,7 @@ resolve_fntype (gfc_namespace * ns)
/* 12.3.2.1.1 Defined operators. */ /* 12.3.2.1.1 Defined operators. */
static void static void
gfc_resolve_uops(gfc_symtree *symtree) gfc_resolve_uops (gfc_symtree *symtree)
{ {
gfc_interface *itr; gfc_interface *itr;
gfc_symbol *sym; gfc_symbol *sym;
...@@ -7179,19 +7152,20 @@ gfc_resolve_uops(gfc_symtree *symtree) ...@@ -7179,19 +7152,20 @@ gfc_resolve_uops(gfc_symtree *symtree)
{ {
sym = itr->sym; sym = itr->sym;
if (!sym->attr.function) if (!sym->attr.function)
gfc_error("User operator procedure '%s' at %L must be a FUNCTION", gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
sym->name, &sym->declared_at); sym->name, &sym->declared_at);
if (sym->ts.type == BT_CHARACTER if (sym->ts.type == BT_CHARACTER
&& !(sym->ts.cl && sym->ts.cl->length) && !(sym->ts.cl && sym->ts.cl->length)
&& !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length)) && !(sym->result && sym->result->ts.cl
gfc_error("User operator procedure '%s' at %L cannot be assumed character " && sym->result->ts.cl->length))
"length", sym->name, &sym->declared_at); gfc_error ("User operator procedure '%s' at %L cannot be assumed "
"character length", sym->name, &sym->declared_at);
formal = sym->formal; formal = sym->formal;
if (!formal || !formal->sym) if (!formal || !formal->sym)
{ {
gfc_error("User operator procedure '%s' at %L must have at least " gfc_error ("User operator procedure '%s' at %L must have at least "
"one argument", sym->name, &sym->declared_at); "one argument", sym->name, &sym->declared_at);
continue; continue;
} }
...@@ -7230,7 +7204,7 @@ gfc_resolve_uops(gfc_symtree *symtree) ...@@ -7230,7 +7204,7 @@ gfc_resolve_uops(gfc_symtree *symtree)
block, which is handled by resolve_code. */ block, which is handled by resolve_code. */
static void static void
resolve_types (gfc_namespace * ns) resolve_types (gfc_namespace *ns)
{ {
gfc_namespace *n; gfc_namespace *n;
gfc_charlen *cl; gfc_charlen *cl;
...@@ -7289,7 +7263,7 @@ resolve_types (gfc_namespace * ns) ...@@ -7289,7 +7263,7 @@ resolve_types (gfc_namespace * ns)
/* Call resolve_code recursively. */ /* Call resolve_code recursively. */
static void static void
resolve_codes (gfc_namespace * ns) resolve_codes (gfc_namespace *ns)
{ {
gfc_namespace *n; gfc_namespace *n;
...@@ -7311,7 +7285,7 @@ resolve_codes (gfc_namespace * ns) ...@@ -7311,7 +7285,7 @@ resolve_codes (gfc_namespace * ns)
which functions or subroutines. */ which functions or subroutines. */
void void
gfc_resolve (gfc_namespace * ns) gfc_resolve (gfc_namespace *ns)
{ {
gfc_namespace *old_ns; gfc_namespace *old_ns;
......
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;
...@@ -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,9 +833,9 @@ restart: ...@@ -835,9 +833,9 @@ 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,7 +1232,7 @@ preprocessor_line (char *c) ...@@ -1234,7 +1232,7 @@ 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;
...@@ -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)
{ {
...@@ -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,18 +1340,12 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z) ...@@ -1350,18 +1340,12 @@ 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;
...@@ -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,8 +2312,8 @@ simplify_min_max (gfc_expr * expr, int sign) ...@@ -2334,8 +2312,8 @@ 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);
...@@ -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;
...@@ -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;
...@@ -3226,8 +3199,8 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b) ...@@ -3226,8 +3199,8 @@ gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
{ {
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;
} }
...@@ -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;
...@@ -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;
...@@ -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;
...@@ -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)
...@@ -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