+2007-01-20 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ * openmp.c, matchexp.c, module.c, scanner.c, resolve.c, st.c,
+ parse.c, primary.c, options.c, misc.c, simplify.c: Next installment
+ in the massive whitespace patch.
+
2007-01-20 Roger Sayle <roger@eyesopen.com>
* module.c (mio_array_ref): The dimen_type fields of an array ref
/* Expression parser.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "gfortran.h"
operator already. */
static match
-match_defined_operator (gfc_user_op ** result)
+match_defined_operator (gfc_user_op **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
/* Call the INTRINSIC_PARENTHESES function. This is both
used explicitly, as below, or by resolve.c to generate
temporaries. */
+
gfc_expr *
gfc_get_parentheses (gfc_expr *e)
{
/* Match a primary expression. */
static match
-match_primary (gfc_expr ** result)
+match_primary (gfc_expr **result)
{
match m;
gfc_expr *e;
/* Build an operator expression node. */
static gfc_expr *
-build_node (gfc_intrinsic_op operator, locus * where,
- gfc_expr * op1, gfc_expr * op2)
+build_node (gfc_intrinsic_op operator, locus *where,
+ gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *new;
/* Match a level 1 expression. */
static match
-match_level_1 (gfc_expr ** result)
+match_level_1 (gfc_expr **result)
{
gfc_user_op *uop;
gfc_expr *e, *f;
or add-operand
*/
-static match match_ext_mult_operand (gfc_expr ** result);
-static match match_ext_add_operand (gfc_expr ** result);
-
+static match match_ext_mult_operand (gfc_expr **result);
+static match match_ext_add_operand (gfc_expr **result);
static int
match_add_op (void)
{
-
if (next_operator (INTRINSIC_MINUS))
return -1;
if (next_operator (INTRINSIC_PLUS))
static match
-match_mult_operand (gfc_expr ** result)
+match_mult_operand (gfc_expr **result)
{
gfc_expr *e, *exp, *r;
locus where;
static match
-match_ext_mult_operand (gfc_expr ** result)
+match_ext_mult_operand (gfc_expr **result)
{
gfc_expr *all, *e;
locus where;
if (i == 0)
return match_mult_operand (result);
- if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
- " arithmetic operator (use parentheses) at %C")
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
+ "arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
static match
-match_add_operand (gfc_expr ** result)
+match_add_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where, old_loc;
static match
-match_ext_add_operand (gfc_expr ** result)
+match_ext_add_operand (gfc_expr **result)
{
gfc_expr *all, *e;
locus where;
if (i == 0)
return match_add_operand (result);
- if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
- " arithmetic operator (use parentheses) at %C")
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following "
+ "arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
/* Match a level 2 expression. */
static match
-match_level_2 (gfc_expr ** result)
+match_level_2 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
all->where = where;
-/* Append add-operands to the sum */
+ /* Append add-operands to the sum. */
for (;;)
{
/* Match a level three expression. */
static match
-match_level_3 (gfc_expr ** result)
+match_level_3 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
/* Match a level 4 expression. */
static match
-match_level_4 (gfc_expr ** result)
+match_level_4 (gfc_expr **result)
{
gfc_expr *left, *right, *r;
gfc_intrinsic_op i;
static match
-match_and_operand (gfc_expr ** result)
+match_and_operand (gfc_expr **result)
{
gfc_expr *e, *r;
locus where;
static match
-match_or_operand (gfc_expr ** result)
+match_or_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
static match
-match_equiv_operand (gfc_expr ** result)
+match_equiv_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
/* Match a level 5 expression. */
static match
-match_level_5 (gfc_expr ** result)
+match_level_5 (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where;
level 5 expressions separated by binary operators. */
match
-gfc_match_expr (gfc_expr ** result)
+gfc_match_expr (gfc_expr **result)
{
gfc_expr *all, *e;
gfc_user_op *uop;
/* Miscellaneous stuff that doesn't fit anywhere else.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "gfortran.h"
-
/* Get a block of memory. Many callers assume that the memory we
return is zeroed. */
void
gfc_free (void *p)
{
-
if (p != NULL)
free (p);
}
#undef temp
-/* Get terminal width */
+/* Get terminal width. */
int
-gfc_terminal_width(void)
+gfc_terminal_width (void)
{
return 80;
}
/* Initialize a typespec to unknown. */
void
-gfc_clear_ts (gfc_typespec * ts)
+gfc_clear_ts (gfc_typespec *ts)
{
-
ts->type = BT_UNKNOWN;
ts->kind = 0;
ts->derived = NULL;
the argument list of a single statement. */
const char *
-gfc_typename (gfc_typespec * ts)
+gfc_typename (gfc_typespec *ts)
{
- static char buffer1[60], buffer2[60];
+ static char buffer1[60], buffer2[60]; /* FIXME: Buffer overflow. */
static int flag = 0;
char *buffer;
returning a pointer to the string. */
const char *
-gfc_code2string (const mstring * m, int code)
+gfc_code2string (const mstring *m, int code)
{
-
while (m->string != NULL)
{
if (m->tag == code)
/* Given an mstring array and a string, returns the value of the tag
- field. Returns the final tag if no matches to the string are
- found. */
+ field. Returns the final tag if no matches to the string are found. */
int
-gfc_string2code (const mstring * m, const char *string)
+gfc_string2code (const mstring *m, const char *string)
{
-
for (; m->string != NULL; m++)
if (strcmp (m->string, string) == 0)
return m->tag;
/* Convert an intent code to a string. */
/* TODO: move to gfortran.h as define. */
+
const char *
gfc_intent_string (sym_intent i)
{
-
return gfc_code2string (intents, i);
}
void
gfc_init_2 (void)
{
-
gfc_symbol_init_2 ();
gfc_module_init_2 ();
}
void
gfc_done_2 (void)
{
-
gfc_symbol_done_2 ();
gfc_module_done_2 ();
}
/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free
- Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
/* Recursively free the tree of pointer structures. */
static void
-free_pi_tree (pointer_info * p)
+free_pi_tree (pointer_info *p)
{
if (p == NULL)
return;
module. */
static int
-compare_pointers (void * _sn1, void * _sn2)
+compare_pointers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
module. */
static int
-compare_integers (void * _sn1, void * _sn2)
+compare_integers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
/* Recursive function to find a pointer within a tree by brute force. */
static pointer_info *
-fp2 (pointer_info * p, const void *target)
+fp2 (pointer_info *p, const void *target)
{
pointer_info *q;
static pointer_info *
find_pointer2 (void *p)
{
-
return fp2 (pi_root, p);
}
/* Resolve any fixups using a known pointer. */
static void
-resolve_fixups (fixup_t *f, void * gp)
+resolve_fixups (fixup_t *f, void *gp)
{
fixup_t *next;
}
}
+
/* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at
this time. */
static void
-associate_integer_pointer (pointer_info * p, void *gp)
+associate_integer_pointer (pointer_info *p, void *gp)
{
if (p->u.pointer != NULL)
gfc_internal_error ("associate_integer_pointer(): Already associated");
tail = new;
/* See what kind of interface we're dealing with. Assume it is
- not an operator. */
+ not an operator. */
new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
goto cleanup;
return (u->local_name[0] != '\0') ? u->local_name : name;
}
+
/* Given a name, return the name under which to load this symbol.
Returns NULL if this symbol shouldn't be loaded. */
return find_use_name_n (name, &i);
}
-/* Given a real name, return the number of use names associated
- with it. */
+
+/* Given a real name, return the number of use names associated with it. */
static int
number_use_names (const char *name)
/* Compare two true_name structures. */
static int
-compare_true_names (void * _t1, void * _t2)
+compare_true_names (void *_t1, void *_t2)
{
true_name *t1, *t2;
int c;
p = true_name_root;
while (p != NULL)
{
- c = compare_true_names ((void *)(&t), (void *) p);
+ c = compare_true_names ((void *) (&t), (void *) p);
if (c == 0)
return p->sym;
}
-/* Given a gfc_symbol pointer that is not in the true name tree, add
- it. */
+/* Given a gfc_symbol pointer that is not in the true name tree, add it. */
static void
-add_true_name (gfc_symbol * sym)
+add_true_name (gfc_symbol *sym)
{
true_name *t;
recursively traversing the current namespace. */
static void
-build_tnt (gfc_symtree * st)
+build_tnt (gfc_symtree *st)
{
-
if (st == NULL)
return;
init_true_name_tree (void)
{
true_name_root = NULL;
-
build_tnt (gfc_current_ns->sym_root);
}
/* Recursively free a true name tree node. */
static void
-free_true_name (true_name * t)
+free_true_name (true_name *t)
{
-
if (t == NULL)
return;
free_true_name (t->left);
/* Set the module's input pointer. */
static void
-set_module_locus (module_locus * m)
+set_module_locus (module_locus *m)
{
-
module_column = m->column;
module_line = m->line;
fsetpos (module_fp, &m->pos);
/* Get the module's input pointer so that we can restore it later. */
static void
-get_module_locus (module_locus * m)
+get_module_locus (module_locus *m)
{
-
m->column = module_column;
m->line = module_line;
fgetpos (module_fp, &m->pos);
bad_module ("Unexpected end of module in string constant");
if (c != '\'')
- {
+ {
len++;
continue;
}
c = module_char ();
if (c == '\'')
- {
+ {
len++;
continue;
}
{
c = module_char ();
if (c == '\'')
- module_char (); /* Guaranteed to be another \' */
+ module_char (); /* Guaranteed to be another \' */
*p++ = c;
}
- module_char (); /* Terminating \' */
- *p = '\0'; /* C-style string for debug purposes */
+ module_char (); /* Terminating \' */
+ *p = '\0'; /* C-style string for debug purposes. */
}
be one of the strings in the array. We return the enum value. */
static int
-find_enum (const mstring * m)
+find_enum (const mstring *m)
{
int i;
static void
write_char (char out)
{
-
if (fputc (out, module_fp) == EOF)
gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
pointer because enums are sometimes inside bitfields. */
static int
-mio_name (int t, const mstring * m)
+mio_name (int t, const mstring *m)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_NAME, gfc_code2string (m, t));
else
#define DECL_MIO_NAME(TYPE) \
static inline TYPE \
- MIO_NAME(TYPE) (TYPE t, const mstring * m) \
+ MIO_NAME(TYPE) (TYPE t, const mstring *m) \
{ \
- return (TYPE)mio_name ((int)t, m); \
+ return (TYPE) mio_name ((int) t, m); \
}
#define MIO_NAME(TYPE) mio_name_##TYPE
static void
mio_lparen (void)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_LPAREN, NULL);
else
static void
mio_rparen (void)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_RPAREN, NULL);
else
static void
mio_integer (int *ip)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_INTEGER, ip);
else
static void
mio_internal_string (char *string)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_STRING, string);
else
};
/* Specialization of mio_name. */
-DECL_MIO_NAME(ab_attribute)
-DECL_MIO_NAME(ar_type)
-DECL_MIO_NAME(array_type)
-DECL_MIO_NAME(bt)
-DECL_MIO_NAME(expr_t)
-DECL_MIO_NAME(gfc_access)
-DECL_MIO_NAME(gfc_intrinsic_op)
-DECL_MIO_NAME(ifsrc)
-DECL_MIO_NAME(procedure_type)
-DECL_MIO_NAME(ref_type)
-DECL_MIO_NAME(sym_flavor)
-DECL_MIO_NAME(sym_intent)
+DECL_MIO_NAME (ab_attribute)
+DECL_MIO_NAME (ar_type)
+DECL_MIO_NAME (array_type)
+DECL_MIO_NAME (bt)
+DECL_MIO_NAME (expr_t)
+DECL_MIO_NAME (gfc_access)
+DECL_MIO_NAME (gfc_intrinsic_op)
+DECL_MIO_NAME (ifsrc)
+DECL_MIO_NAME (procedure_type)
+DECL_MIO_NAME (ref_type)
+DECL_MIO_NAME (sym_flavor)
+DECL_MIO_NAME (sym_intent)
#undef DECL_MIO_NAME
/* Symbol attributes are stored in list with the first three elements
written. */
static void
-mio_symbol_attribute (symbol_attribute * attr)
+mio_symbol_attribute (symbol_attribute *attr)
{
atom_type t;
mio_lparen ();
- attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
- attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
- attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
- attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
+ attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
+ attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
+ attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
+ attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
if (iomode == IO_OUTPUT)
{
if (attr->allocatable)
- MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
if (attr->dimension)
- MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
+ MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->external)
- MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
+ MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
if (attr->intrinsic)
- MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
+ MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
if (attr->optional)
- MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
+ MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
if (attr->pointer)
- MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
+ MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
if (attr->protected)
- MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits);
+ MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
if (attr->save)
- MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
if (attr->value)
- MIO_NAME(ab_attribute) (AB_VALUE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
if (attr->volatile_)
- MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
if (attr->target)
- MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
+ MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
if (attr->threadprivate)
- MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy)
- MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
+ MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result)
- MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
+ MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
/* We deliberately don't preserve the "entry" flag. */
if (attr->data)
- MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
+ MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
if (attr->in_namelist)
- MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
+ MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
if (attr->in_common)
- MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
+ MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
if (attr->function)
- MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
+ MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
if (attr->subroutine)
- MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
if (attr->generic)
- MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
+ MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
if (attr->sequence)
- MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
if (attr->elemental)
- MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure)
- MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->recursive)
- MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
- MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
if (attr->cray_pointer)
- MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
+ MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
if (attr->cray_pointee)
- MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
if (attr->alloc_comp)
- MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
mio_rparen ();
}
else
{
-
for (;;)
{
t = parse_atom ();
case AB_RECURSIVE:
attr->recursive = 1;
break;
- case AB_ALWAYS_EXPLICIT:
- attr->always_explicit = 1;
- break;
+ case AB_ALWAYS_EXPLICIT:
+ attr->always_explicit = 1;
+ break;
case AB_CRAY_POINTER:
attr->cray_pointer = 1;
break;
static void
-mio_charlen (gfc_charlen ** clp)
+mio_charlen (gfc_charlen **clp)
{
gfc_charlen *cl;
}
else
{
-
if (peek_atom () != ATOM_RPAREN)
{
cl = gfc_get_charlen ();
within the namespace and corresponds to an illegal fortran name. */
static gfc_symtree *
-get_unique_symtree (gfc_namespace * ns)
+get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
static int
check_unique_name (const char *name)
{
-
return *name == '@';
}
static void
-mio_typespec (gfc_typespec * ts)
+mio_typespec (gfc_typespec *ts)
{
-
mio_lparen ();
- ts->type = MIO_NAME(bt) (ts->type, bt_types);
+ ts->type = MIO_NAME (bt) (ts->type, bt_types);
if (ts->type != BT_DERIVED)
mio_integer (&ts->kind);
static void
-mio_array_spec (gfc_array_spec ** asp)
+mio_array_spec (gfc_array_spec **asp)
{
gfc_array_spec *as;
int i;
}
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++)
{
minit (NULL, -1)
};
+
static void
-mio_array_ref (gfc_array_ref * ar)
+mio_array_ref (gfc_array_ref *ar)
{
int i;
mio_lparen ();
- ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
+ ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
mio_integer (&ar->dimen);
switch (ar->type)
the namespace and is not loaded again. */
static void
-mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
+mio_component_ref (gfc_component **cp, gfc_symbol *sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_component *q;
static void
-mio_component (gfc_component * c)
+mio_component (gfc_component *c)
{
pointer_info *p;
int n;
static void
-mio_component_list (gfc_component ** cp)
+mio_component_list (gfc_component **cp)
{
gfc_component *c, *tail;
}
else
{
-
*cp = NULL;
tail = NULL;
static void
-mio_actual_arg (gfc_actual_arglist * a)
+mio_actual_arg (gfc_actual_arglist *a)
{
-
mio_lparen ();
mio_pool_string (&a->name);
mio_expr (&a->expr);
static void
-mio_actual_arglist (gfc_actual_arglist ** ap)
+mio_actual_arglist (gfc_actual_arglist **ap)
{
gfc_actual_arglist *a, *tail;
/* Read and write formal argument lists. */
static void
-mio_formal_arglist (gfc_symbol * sym)
+mio_formal_arglist (gfc_symbol *sym)
{
gfc_formal_arglist *f, *tail;
/* Save or restore a reference to a symbol node. */
void
-mio_symbol_ref (gfc_symbol ** symp)
+mio_symbol_ref (gfc_symbol **symp)
{
pointer_info *p;
/* Save or restore a reference to a symtree node. */
static void
-mio_symtree_ref (gfc_symtree ** stp)
+mio_symtree_ref (gfc_symtree **stp)
{
pointer_info *p;
fixup_t *f;
return;
if (p->type == P_UNKNOWN)
- p->type = P_SYMBOL;
+ p->type = P_SYMBOL;
if (p->u.rsym.state == UNUSED)
p->u.rsym.state = NEEDED;
if (p->u.rsym.symtree != NULL)
- {
- *stp = p->u.rsym.symtree;
- }
+ {
+ *stp = p->u.rsym.symtree;
+ }
else
- {
- f = gfc_getmem (sizeof (fixup_t));
+ {
+ f = gfc_getmem (sizeof (fixup_t));
- f->next = p->u.rsym.stfixup;
- p->u.rsym.stfixup = f;
+ f->next = p->u.rsym.stfixup;
+ p->u.rsym.stfixup = f;
- f->pointer = (void **)stp;
- }
+ f->pointer = (void **)stp;
+ }
}
}
+
static void
-mio_iterator (gfc_iterator ** ip)
+mio_iterator (gfc_iterator **ip)
{
gfc_iterator *iter;
}
-
static void
-mio_constructor (gfc_constructor ** cp)
+mio_constructor (gfc_constructor **cp)
{
gfc_constructor *c, *tail;
}
else
{
-
*cp = NULL;
tail = NULL;
}
-
static const mstring ref_types[] = {
minit ("ARRAY", REF_ARRAY),
minit ("COMPONENT", REF_COMPONENT),
static void
-mio_ref (gfc_ref ** rp)
+mio_ref (gfc_ref **rp)
{
gfc_ref *r;
mio_lparen ();
r = *rp;
- r->type = MIO_NAME(ref_type) (r->type, ref_types);
+ r->type = MIO_NAME (ref_type) (r->type, ref_types);
switch (r->type)
{
static void
-mio_ref_list (gfc_ref ** rp)
+mio_ref_list (gfc_ref **rp)
{
gfc_ref *ref, *head, *tail;
/* Read and write an integer value. */
static void
-mio_gmp_integer (mpz_t * integer)
+mio_gmp_integer (mpz_t *integer)
{
char *p;
bad_module ("Error converting integer");
gfc_free (atom_string);
-
}
else
{
static void
-mio_gmp_real (mpfr_t * real)
+mio_gmp_real (mpfr_t *real)
{
mp_exp_t exponent;
char *p;
mpfr_init (*real);
mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string);
-
}
else
{
/* Save and restore the shape of an array constructor. */
static void
-mio_shape (mpz_t ** pshape, int rank)
+mio_shape (mpz_t **pshape, int rank)
{
mpz_t *shape;
atom_type t;
yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name(e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
- e->symtree->n.sym->name);
+ e->symtree->n.sym->name);
/* On the other hand, if the existing symbol is the module name or the
new symbol is a dummy argument, do not do the promotion. */
if (ns_st && ns_st->n.sym
- && ns_st->n.sym->attr.flavor != FL_MODULE
- && !e->symtree->n.sym->attr.dummy)
+ && ns_st->n.sym->attr.flavor != FL_MODULE
+ && !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st;
}
else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
expression, in one use associated module, can fail to be
coupled to its symtree when used in a specification
expression in another module. */
- fname = e->value.function.esym ? e->value.function.esym->name :
- e->value.function.isym->name;
+ fname = e->value.function.esym ? e->value.function.esym->name
+ : e->value.function.isym->name;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
}
}
NULL expression. */
static void
-mio_expr (gfc_expr ** ep)
+mio_expr (gfc_expr **ep)
{
gfc_expr *e;
atom_type t;
}
e = *ep;
- MIO_NAME(expr_t) (e->expr_type, expr_types);
-
+ MIO_NAME (expr_t) (e->expr_type, expr_types);
}
else
{
{
case EXPR_OP:
e->value.op.operator
- = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
+ = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
switch (e->value.op.operator)
{
mio_symbol_ref (&e->value.function.esym);
else
write_atom (ATOM_STRING, e->value.function.isym->name);
-
}
else
{
break;
case EXPR_SUBSTRING:
- e->value.character.string = (char *)
- mio_allocated_string (e->value.character.string);
+ e->value.character.string
+ = (char *) mio_allocated_string (e->value.character.string);
mio_ref_list (&e->ref);
break;
break;
case BT_REAL:
- gfc_set_model_kind (e->ts.kind);
+ gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real);
break;
case BT_COMPLEX:
- gfc_set_model_kind (e->ts.kind);
+ gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.complex.r);
mio_gmp_real (&e->value.complex.i);
break;
case BT_CHARACTER:
mio_integer (&e->value.character.length);
- e->value.character.string = (char *)
- mio_allocated_string (e->value.character.string);
+ e->value.character.string
+ = (char *) mio_allocated_string (e->value.character.string);
break;
default:
/* Read and write namelists */
static void
-mio_namelist (gfc_symbol * sym)
+mio_namelist (gfc_symbol *sym)
{
gfc_namelist *n, *m;
const char *check_name;
{
check_name = find_use_name (sym->name);
if (check_name && strcmp (check_name, sym->name) != 0)
- gfc_error("Namelist %s cannot be renamed by USE"
- " association to %s",
- sym->name, check_name);
+ gfc_error ("Namelist %s cannot be renamed by USE "
+ "association to %s", sym->name, check_name);
}
m = NULL;
be done later when all symbols have been loaded. */
static void
-mio_interface_rest (gfc_interface ** ip)
+mio_interface_rest (gfc_interface **ip)
{
gfc_interface *tail, *p;
}
else
{
-
if (*ip == NULL)
tail = NULL;
else
/* Save/restore a nameless operator interface. */
static void
-mio_interface (gfc_interface ** ip)
+mio_interface (gfc_interface **ip)
{
-
mio_lparen ();
mio_interface_rest (ip);
}
static void
mio_symbol_interface (const char **name, const char **module,
- gfc_interface ** ip)
+ gfc_interface **ip)
{
-
mio_lparen ();
-
mio_pool_string (name);
mio_pool_string (module);
-
mio_interface_rest (ip);
}
static void
-mio_namespace_ref (gfc_namespace ** nsp)
+mio_namespace_ref (gfc_namespace **nsp)
{
gfc_namespace *ns;
pointer_info *p;
if (iomode == IO_INPUT && p->integer != 0)
{
- ns = (gfc_namespace *)p->u.pointer;
+ ns = (gfc_namespace *) p->u.pointer;
if (ns == NULL)
{
ns = gfc_get_namespace (NULL, 0);
}
-/* Unlike most other routines, the address of the symbol node is
- already fixed on input and the name/module has already been filled
- in. */
+/* Unlike most other routines, the address of the symbol node is already
+ fixed on input and the name/module has already been filled in. */
static void
-mio_symbol (gfc_symbol * sym)
+mio_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
mio_component_list (&sym->components);
if (sym->components != NULL)
- sym->component_access =
- MIO_NAME(gfc_access) (sym->component_access, access_types);
+ sym->component_access
+ = MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym);
mio_rparen ();
if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
{
while (parse_atom () != ATOM_RPAREN);
- continue;
+ continue;
}
if (sym == NULL)
/* Load common blocks. */
static void
-load_commons(void)
+load_commons (void)
{
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *p;
mio_lparen ();
p->threadprivate = 1;
p->use_assoc = 1;
- mio_rparen();
+ mio_rparen ();
}
- mio_rparen();
+ mio_rparen ();
}
+
/* load_equiv()-- Load equivalences. The flag in_load_equiv informs
mio_expr_ref of this so that unused variables are not loaded and
so that the expression can be safely freed.*/
static void
-load_equiv(void)
+load_equiv (void)
{
gfc_equiv *head, *tail, *end, *eq;
bool unused;
- mio_lparen();
+ mio_lparen ();
in_load_equiv = true;
end = gfc_current_ns->equiv;
- while(end != NULL && end->next != NULL)
+ while (end != NULL && end->next != NULL)
end = end->next;
- while(peek_atom() != ATOM_RPAREN) {
- mio_lparen();
+ while (peek_atom() != ATOM_RPAREN) {
+ mio_lparen ();
head = tail = NULL;
- while(peek_atom() != ATOM_RPAREN)
+ while(peek_atom () != ATOM_RPAREN)
{
if (head == NULL)
- head = tail = gfc_get_equiv();
+ head = tail = gfc_get_equiv ();
else
{
- tail->eq = gfc_get_equiv();
+ tail->eq = gfc_get_equiv ();
tail = tail->eq;
}
- mio_pool_string(&tail->module);
- mio_expr(&tail->expr);
+ mio_pool_string (&tail->module);
+ mio_expr (&tail->expr);
}
/* Unused variables have no symtree. */
if (head != NULL)
end = head;
- mio_rparen();
+ mio_rparen ();
}
- mio_rparen();
+ mio_rparen ();
in_load_equiv = false;
}
traversal, because the act of loading can alter the tree. */
static int
-load_needed (pointer_info * p)
+load_needed (pointer_info *p)
{
gfc_namespace *ns;
pointer_info *q;
read. */
static void
-read_cleanup (pointer_info * p)
+read_cleanup (pointer_info *p)
{
gfc_symtree *st;
pointer_info *q;
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
if (sym == NULL
- || (sym->attr.flavor == FL_VARIABLE
- && info->u.rsym.ns !=1))
+ || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
continue;
info->u.rsym.state = USED;
}
else
{
- /* Create a symtree node in the current namespace for this symbol. */
- st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
- gfc_new_symtree (&gfc_current_ns->sym_root, p);
+ /* Create a symtree node in the current namespace for this
+ symbol. */
+ st = check_unique_name (p)
+ ? get_unique_symtree (gfc_current_ns)
+ : gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;
/* Create a symbol node if it doesn't already exist. */
if (sym == NULL)
{
- sym = info->u.rsym.sym =
- gfc_new_symbol (info->u.rsym.true_name,
- gfc_current_ns);
-
+ info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
+ gfc_current_ns);
+ sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
}
info->u.rsym.symtree = st;
if (info->u.rsym.state == UNUSED)
- info->u.rsym.state = NEEDED;
+ info->u.rsym.state = NEEDED;
info->u.rsym.referenced = 1;
}
}
load_generic_interfaces ();
load_commons ();
- load_equiv();
+ load_equiv ();
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
while (load_needed (pi_root));
- /* Make sure all elements of the rename-list were found in the
- module. */
+ /* Make sure all elements of the rename-list were found in the module. */
for (u = gfc_rename_list; u; u = u->next)
{
if (u->operator == INTRINSIC_USER)
{
- gfc_error
- ("User operator '%s' referenced at %L not found in module '%s'",
- u->use_name, &u->where, module_name);
+ gfc_error ("User operator '%s' referenced at %L not found "
+ "in module '%s'", u->use_name, &u->where, module_name);
continue;
}
- gfc_error
- ("Intrinsic operator '%s' referenced at %L not found in module "
- "'%s'", gfc_op2string (u->operator), &u->where, module_name);
+ gfc_error ("Intrinsic operator '%s' referenced at %L not found "
+ "in module '%s'", gfc_op2string (u->operator), &u->where,
+ module_name);
}
gfc_check_interfaces (gfc_current_ns);
bool
gfc_check_access (gfc_access specific_access, gfc_access default_access)
{
-
if (specific_access == ACCESS_PUBLIC)
return TRUE;
if (specific_access == ACCESS_PRIVATE)
if (st == NULL)
return;
- write_common(st->left);
- write_common(st->right);
+ write_common (st->left);
+ write_common (st->right);
- mio_lparen();
+ mio_lparen ();
/* Write the unmangled name. */
name = st->n.common->name;
- mio_pool_string(&name);
+ mio_pool_string (&name);
p = st->n.common;
- mio_symbol_ref(&p->head);
+ mio_symbol_ref (&p->head);
flags = p->saved ? 1 : 0;
if (p->threadprivate) flags |= 2;
- mio_integer(&flags);
+ mio_integer (&flags);
- mio_rparen();
+ mio_rparen ();
}
/* Write the blank common block to the module */
if (gfc_current_ns->blank_common.head == NULL)
return;
- mio_lparen();
+ mio_lparen ();
- mio_pool_string(&name);
+ mio_pool_string (&name);
- mio_symbol_ref(&gfc_current_ns->blank_common.head);
+ mio_symbol_ref (&gfc_current_ns->blank_common.head);
saved = gfc_current_ns->blank_common.saved;
- mio_integer(&saved);
+ mio_integer (&saved);
- mio_rparen();
+ mio_rparen ();
}
+
/* Write equivalences to the module. */
static void
-write_equiv(void)
+write_equiv (void)
{
gfc_equiv *eq, *e;
int num;
num = 0;
- for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
+ for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
{
- mio_lparen();
+ mio_lparen ();
- for(e=eq; e; e=e->eq)
+ for (e = eq; e; e = e->eq)
{
if (e->module == NULL)
- e->module = gfc_get_string("%s.eq.%d", module_name, num);
- mio_allocated_string(e->module);
- mio_expr(&e->expr);
+ e->module = gfc_get_string ("%s.eq.%d", module_name, num);
+ mio_allocated_string (e->module);
+ mio_expr (&e->expr);
}
num++;
- mio_rparen();
+ mio_rparen ();
}
}
+
/* Write a symbol to the module. */
static void
-write_symbol (int n, gfc_symbol * sym)
+write_symbol (int n, gfc_symbol *sym)
{
if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
according to the access specification. */
static void
-write_symbol0 (gfc_symtree * st)
+write_symbol0 (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
symbol was written and pass that information upwards. */
static int
-write_symbol1 (pointer_info * p)
+write_symbol1 (pointer_info *p)
{
-
if (p == NULL)
return 0;
/* Write operator interfaces associated with a symbol. */
static void
-write_operator (gfc_user_op * uop)
+write_operator (gfc_user_op *uop)
{
static char nullstring[] = "";
const char *p = nullstring;
/* Write generic interfaces associated with a symbol. */
static void
-write_generic (gfc_symbol * sym)
+write_generic (gfc_symbol *sym)
{
-
if (sym->generic == NULL
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
static void
-write_symtree (gfc_symtree * st)
+write_symtree (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
write_char ('\n');
write_char ('\n');
- mio_lparen();
- write_equiv();
- mio_rparen();
- write_char('\n'); write_char('\n');
+ mio_lparen ();
+ write_equiv ();
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
static void
create_int_parameter (const char *name, int value, const char *modname)
{
- gfc_symtree * tmp_symtree;
- gfc_symbol * sym;
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL)
sym->attr.use_assoc = 1;
}
+
/* USE the ISO_FORTRAN_ENV intrinsic module. */
+
static void
use_iso_fortran_env_module (void)
{
}
}
+
/* Process a USE directive. */
void
int c, line, start;
gfc_symtree *mod_symtree;
- filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
- + 1);
+ filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
+ + 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
if (module_fp == NULL && !specified_nonint)
{
if (strcmp (module_name, "iso_fortran_env") == 0
- && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
- "ISO_FORTRAN_ENV intrinsic module at %C") != FAILURE)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
+ "intrinsic module at %C") != FAILURE)
{
- use_iso_fortran_env_module ();
- return;
+ use_iso_fortran_env_module ();
+ return;
}
module_fp = gfc_open_intrinsic_module (filename);
if (module_fp == NULL && specified_int)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
- module_name);
+ module_name);
}
if (module_fp == NULL)
if (start++ < 2)
parse_name (c);
if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
- || (start == 2 && strcmp (atom_name, " module") != 0))
+ || (start == 2 && strcmp (atom_name, " module") != 0))
gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
- "file", filename);
+ "file", filename);
if (c == '\n')
line++;
void
gfc_module_init_2 (void)
{
-
last_atom = ATOM_LPAREN;
}
void
gfc_module_done_2 (void)
{
-
free_rename ();
}
/* OpenMP directive matching and resolving.
- Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Jakub Jelinek
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
return MATCH_YES;
}
+
match
gfc_match_omp_critical (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_do (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_flush (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_threadprivate (void)
{
{
case MATCH_YES:
if (sym->attr.in_common)
- gfc_error_now ("Threadprivate variable at %C is an element of"
- " a COMMON block");
+ gfc_error_now ("Threadprivate variable at %C is an element of "
+ "a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
return MATCH_ERROR;
}
+
match
gfc_match_omp_parallel_do (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_parallel_sections (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_parallel_workshare (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_sections (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_single (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_workshare (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_master (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_ordered (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_atomic (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_barrier (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_end_nowait (void)
{
return MATCH_YES;
}
+
match
gfc_match_omp_end_single (void)
{
return MATCH_YES;
}
+
/* OpenMP directive resolving routines. */
static void
gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
- gfc_error ("NUM_THREADS clause at %L requires a scalar"
- " INTEGER expression", &expr->where);
+ gfc_error ("NUM_THREADS clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
}
if (omp_clauses->chunk_size)
{
gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
- gfc_error ("SCHEDULE clause's chunk_size at %L requires"
- " a scalar INTEGER expression", &expr->where);
+ gfc_error ("SCHEDULE clause's chunk_size at %L requires "
+ "a scalar INTEGER expression", &expr->where);
}
/* Check that no symbol appears on multiple clauses, except that
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array '%s' in COPYPRIVATE clause"
- " at %L", n->sym->name, &code->loc);
+ gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
+ "at %L", n->sym->name, &code->loc);
if (n->sym->attr.allocatable)
- gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE"
- " at %L", n->sym->name, &code->loc);
+ gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
+ "at %L", n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
- gfc_error ("THREADPRIVATE object '%s' in SHARED clause at"
- " %L", n->sym->name, &code->loc);
+ gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
+ "%L", n->sym->name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, &code->loc);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
- gfc_error ("Variable '%s' in %s clause is used in"
- " NAMELIST statement at %L",
+ gfc_error ("Variable '%s' in %s clause is used in "
+ "NAMELIST statement at %L",
n->sym->name, name, &code->loc);
switch (list)
{
case OMP_LIST_EQV:
case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
- gfc_error ("%s REDUCTION variable '%s' must be LOGICAL"
- " at %L",
+ gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
+ "at %L",
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
- gfc_error ("%s REDUCTION variable '%s' must be"
- " INTEGER or REAL at %L",
+ gfc_error ("%s REDUCTION variable '%s' must be "
+ "INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, &code->loc);
break;
case OMP_LIST_IOR:
case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER)
- gfc_error ("%s REDUCTION variable '%s' must be INTEGER"
- " at %L",
+ gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
+ "at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, &code->loc);
}
}
+
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
static bool
}
}
+
/* If EXPR is a conversion function that widens the type
if WIDENING is true or narrows the type if WIDENING is false,
return the inner expression, otherwise return NULL. */
return NULL;
}
+
static void
resolve_omp_atomic (gfc_code *code)
{
&& code->expr->ts.type != BT_COMPLEX
&& code->expr->ts.type != BT_LOGICAL))
{
- gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
- " intrinsic type at %L", &code->loc);
+ gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
+ "intrinsic type at %L", &code->loc);
return;
}
alt_op = INTRINSIC_EQV;
break;
default:
- gfc_error ("!$OMP ATOMIC assignment operator must be"
- " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+ gfc_error ("!$OMP ATOMIC assignment operator must be "
+ "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where);
return;
}
if (v == NULL)
{
- gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
- " or var = expr op var at %L", &expr2->where);
+ gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
+ "or var = expr op var at %L", &expr2->where);
return;
}
case INTRINSIC_DIVIDE:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
- gfc_error ("!$OMP ATOMIC var = var op expr not"
- " mathematically equivalent to var = var op"
- " (expr) at %L", &expr2->where);
+ gfc_error ("!$OMP ATOMIC var = var op expr not "
+ "mathematically equivalent to var = var op "
+ "(expr) at %L", &expr2->where);
break;
default:
break;
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
{
- gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
- " must be scalar and cannot reference var at %L",
+ gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
+ "must be scalar and cannot reference var at %L",
&expr2->where);
return;
}
case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL)
{
- gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
+ gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
"or IEOR must have two arguments at %L",
&expr2->where);
return;
}
break;
default:
- gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
- " MIN, MAX, IAND, IOR or IEOR at %L",
+ gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
+ "MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where);
return;
}
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
- gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
- " reference '%s' at %L", var->name, &arg->expr->where);
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
+ "reference '%s' at %L", var->name, &arg->expr->where);
if (arg->expr->rank != 0)
- gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
- " at %L", &arg->expr->where);
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
+ "at %L", &arg->expr->where);
}
if (var_arg == NULL)
{
- gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
- " be '%s' at %L", var->name, &expr2->where);
+ gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
+ "be '%s' at %L", var->name, &expr2->where);
return;
}
}
}
else
- gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
- " on right hand side at %L", &expr2->where);
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
+ "on right hand side at %L", &expr2->where);
}
+
struct omp_context
{
gfc_code *code;
} *omp_current_ctx;
gfc_code *omp_current_do_code;
+
void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
{
gfc_resolve_blocks (code->block, ns);
}
+
void
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
{
pointer_set_destroy (ctx.private_iterators);
}
+
/* Note a DO iterator variable. This is special in !$omp parallel
construct, where they are predetermined private. */
}
}
+
static void
resolve_omp_do (gfc_code *code)
{
do_code = code->block->next;
if (do_code->op == EXEC_DO_WHILE)
- gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
- &do_code->loc);
+ gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
+ "at %L", &do_code->loc);
else
{
gcc_assert (do_code->op == EXEC_DO);
&do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
- gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
- &do_code->loc);
+ gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
+ "at %L", &do_code->loc);
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym)
{
- gfc_error ("!$OMP DO iteration variable present on clause"
- " other than PRIVATE or LASTPRIVATE at %L",
+ gfc_error ("!$OMP DO iteration variable present on clause "
+ "other than PRIVATE or LASTPRIVATE at %L",
&do_code->loc);
break;
}
}
}
+
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */
/* Parse and display command line options.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "params.h"
#include "tree-inline.h"
-
#include "gfortran.h"
#include "target.h"
gfc_option.fpe = 0;
- /* Argument pointers cannot point to anything
- but their argument. */
+ /* Argument pointers cannot point to anything but their argument. */
flag_argument_noalias = 3;
flag_errno_math = 0;
gfc_option.fshort_enums = targetm.default_short_enums ();
/* Increase MAX_ALIASED_VOPS to account for different characteristics
- of fortran regarding VOPs. */
+ of Fortran regarding VOPs. */
MAX_ALIASED_VOPS = 50;
return CL_Fortran;
static gfc_source_form
form_from_filename (const char *filename)
{
-
static const struct
{
const char *extension;
i = strlen (canon_source_file);
while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i]))
i--;
+
if (i != 0)
{
source_path = alloca (i + 1);
gfc_warning_now ("'-fd-lines-as-comments' has no effect "
"in free form");
else if (gfc_option.flag_d_lines == 1)
- gfc_warning_now ("'-fd-lines-as-code' has no effect "
- "in free form");
+ gfc_warning_now ("'-fd-lines-as-code' has no effect in free form");
}
flag_inline_trees = 1;
static void
set_Wall (void)
{
-
gfc_option.warn_aliasing = 1;
gfc_option.warn_ampersand = 1;
gfc_option.warn_line_truncation = 1;
gfc_add_include_path (gfc_option.module_dir, true);
}
+
static void
gfc_handle_fpe_trap_option (const char *arg)
{
int result, pos = 0, n;
static const char * const exception[] = { "invalid", "denormal", "zero",
- "overflow", "underflow",
+ "overflow", "underflow",
"precision", NULL };
static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL,
GFC_FPE_ZERO, GFC_FPE_OVERFLOW,
{
while (*arg == ',')
arg++;
+
while (arg[pos] && arg[pos] != ',')
pos++;
+
result = 0;
for (n = 0; exception[n] != NULL; n++)
{
break;
}
}
- if (! result)
+ if (!result)
gfc_fatal_error ("Argument to -ffpe-trap is not valid: %s", arg);
}
}
+
/* Handle command-line options. Returns 0 if unrecognized, 1 if
recognized and handled. */
+
int
gfc_handle_option (size_t scode, const char *arg, int value)
{
case OPT_fmax_subrecord_length_:
if (value > MAX_SUBRECORD_LENGTH)
- gfc_fatal_error ("Maximum subrecord length cannot exceed %d", MAX_SUBRECORD_LENGTH);
+ gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
+ MAX_SUBRECORD_LENGTH);
gfc_option.max_subrecord_length = value;
}
/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include <setjmp.h>
#include "match.h"
#include "parse.h"
-/* Current statement label. Zero means no statement label. Because
- new_st can get wiped during statement matching, we have to keep it
- separate. */
+/* Current statement label. Zero means no statement label. Because new_st
+ can get wiped during statement matching, we have to keep it separate. */
gfc_st_label *gfc_statement_label;
gfc_match_eos(). */
static match
-match_word (const char *str, match (*subr) (void), locus * old_locus)
+match_word (const char *str, match (*subr) (void), locus *old_locus)
{
match m;
ambiguity. */
#define match(keyword, subr, st) \
- do { \
+ do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
+ return st; \
else \
- undo_new_statement (); \
+ undo_new_statement (); \
} while (0);
static gfc_statement
if (gfc_pure (NULL))
{
- gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
+ gfc_error_now ("OpenMP directives at %C may not appear in PURE "
+ "or ELEMENTAL procedures");
gfc_error_recovery ();
return ST_NONE;
}
{
gfc_match_small_literal_int (&c, &cnt);
- if (cnt > 5)
+ if (cnt > 5)
gfc_error_now ("Too many digits in statement label at %C");
if (c == 0)
if (at_bol && gfc_peek_char () == ';')
{
- gfc_error_now
- ("Semicolon at %C needs to be preceded by statement");
+ gfc_error_now ("Semicolon at %C needs to be preceded by "
+ "statement");
gfc_next_char (); /* Eat up the semicolon. */
return ST_NONE;
}
if (gfc_match_eos () == MATCH_YES)
{
- gfc_warning_now
- ("Ignoring statement label in empty statement at %C");
+ gfc_warning_now ("Ignoring statement label in empty statement "
+ "at %C");
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
break;
}
- st =
- (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
+ st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE)
break;
are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
- case ST_END_PROGRAM: case ST_END_SUBROUTINE
+ case ST_END_PROGRAM: case ST_END_SUBROUTINE
/* Push a new state onto the stack. */
static void
-push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
+push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
{
-
p->state = new_state;
p->previous = gfc_state_stack;
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
-
gfc_state_stack = p;
}
static void
pop_state (void)
{
-
gfc_state_stack = gfc_state_stack->previous;
}
/* Starts a new level in the statement list. */
static gfc_code *
-new_level (gfc_code * q)
+new_level (gfc_code *q)
{
gfc_code *p;
break;
/* Statement labels are not restricted from appearing on a
- particular line. However, there are plenty of situations
- where the resulting label can't be referenced. */
+ particular line. However, there are plenty of situations
+ where the resulting label can't be referenced. */
default:
type = ST_LABEL_BAD_TARGET;
/* Create a symbol for the main program and assign it to ns->proc_name. */
static void
-main_program_symbol (gfc_namespace * ns)
+main_program_symbol (gfc_namespace *ns)
{
gfc_symbol *main_program;
symbol_attribute attr;
static void
accept_statement (gfc_statement st)
{
-
switch (st)
{
case ST_USE:
break;
/* If the statement is the end of a block, lay down a special code
- that allows a branch to the end of the block from within the
- construct. */
+ that allows a branch to the end of the block from within the
+ construct. */
case ST_ENDIF:
case ST_END_SELECT:
break;
/* The end-of-program unit statements do not get the special
- marker and require a statement of some sort if they are a
- branch target. */
+ marker and require a statement of some sort if they are a
+ branch target. */
case ST_END_PROGRAM:
case ST_END_FUNCTION:
static void
unexpected_statement (gfc_statement st)
{
-
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
reject_statement ();
valid before calling here, ie ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
- +---------------------------------------+
- | program subroutine function module |
- +---------------------------------------+
- | use |
- +---------------------------------------+
- | import |
- +---------------------------------------+
- | | implicit none |
- | +-----------+------------------+
- | | parameter | implicit |
- | +-----------+------------------+
- | format | | derived type |
- | entry | parameter | interface |
- | | data | specification |
- | | | statement func |
- | +-----------+------------------+
- | | data | executable |
- +--------+-----------+------------------+
- | contains |
- +---------------------------------------+
- | internal module/subprogram |
- +---------------------------------------+
- | end |
- +---------------------------------------+
+ +---------------------------------------+
+ | program subroutine function module |
+ +---------------------------------------+
+ | use |
+ +---------------------------------------+
+ | import |
+ +---------------------------------------+
+ | | implicit none |
+ | +-----------+------------------+
+ | | parameter | implicit |
+ | +-----------+------------------+
+ | format | | derived type |
+ | entry | parameter | interface |
+ | | data | specification |
+ | | | statement func |
+ | +-----------+------------------+
+ | | data | executable |
+ +--------+-----------+------------------+
+ | contains |
+ +---------------------------------------+
+ | internal module/subprogram |
+ +---------------------------------------+
+ | end |
+ +---------------------------------------+
*/
st_state;
static try
-verify_st_order (st_state * p, gfc_statement st)
+verify_st_order (st_state *p, gfc_statement st)
{
switch (st)
if (p->state > ORDER_IMPLICIT_NONE)
goto order;
- /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
- statement disqualifies a USE but not an IMPLICIT NONE.
- Duplicate IMPLICIT NONEs are caught when the implicit types
- are set. */
+ /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
+ statement disqualifies a USE but not an IMPLICIT NONE.
+ Duplicate IMPLICIT NONEs are caught when the implicit types
+ are set. */
p->state = ORDER_IMPLICIT_NONE;
break;
break;
default:
- gfc_internal_error
- ("Unexpected %s statement in verify_st_order() at %C",
- gfc_ascii_statement (st));
+ gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
+ gfc_ascii_statement (st));
}
/* All is well, record the statement in case we need it next time. */
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
- gfc_error
- ("PRIVATE statement in TYPE at %C must be inside a MODULE");
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
error_flag = 1;
break;
}
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
- if (c->allocatable || (c->ts.type == BT_DERIVED
- && c->ts.derived->attr.alloc_comp))
+ if (c->allocatable
+ || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
{
sym->attr.alloc_comp = 1;
break;
}
-
/* Parse an ENUM. */
static void
{
st = next_statement ();
switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
- break;
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
- case ST_ENUMERATOR:
+ case ST_ENUMERATOR:
seen_enumerator = 1;
- accept_statement (st);
- break;
+ accept_statement (st);
+ break;
- case ST_END_ENUM:
- compiling_enum = 0;
+ case ST_END_ENUM:
+ compiling_enum = 0;
if (!seen_enumerator)
- {
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+ {
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
error_flag = 1;
- }
- accept_statement (st);
- break;
-
- default:
- gfc_free_enum_history ();
- unexpected_statement (st);
- break;
- }
+ }
+ accept_statement (st);
+ break;
+
+ default:
+ gfc_free_enum_history ();
+ unexpected_statement (st);
+ break;
+ }
}
pop_state ();
}
+
/* Parse an interface. We must be able to deal with the possibility
of recursive interfaces. The parse_spec() subroutine is mutually
recursive with parse_interface(). */
save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC
- || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
+ || current_interface.type == INTERFACE_USER_OP)
+ ? gfc_new_block : NULL;
push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE;
if (new_state != current_state)
{
if (new_state == COMP_SUBROUTINE)
- gfc_error
- ("SUBROUTINE at %C does not belong in a generic function "
- "interface");
+ gfc_error ("SUBROUTINE at %C does not belong in a "
+ "generic function interface");
if (new_state == COMP_FUNCTION)
- gfc_error
- ("FUNCTION at %C does not belong in a generic subroutine "
- "interface");
+ gfc_error ("FUNCTION at %C does not belong in a "
+ "generic subroutine interface");
}
}
}
case ST_WHERE_BLOCK:
parse_where_block ();
- break;
+ break;
case ST_ASSIGNMENT:
case ST_WHERE:
case ST_ELSEWHERE:
if (seen_empty_else)
{
- gfc_error
- ("ELSEWHERE statement at %C follows previous unmasked "
- "ELSEWHERE");
+ gfc_error ("ELSEWHERE statement at %C follows previous "
+ "unmasked ELSEWHERE");
break;
}
reject_statement ();
break;
}
-
}
while (st != ST_END_WHERE);
case ST_ELSEIF:
if (seen_else)
{
- gfc_error
- ("ELSE IF statement at %C cannot follow ELSE statement at %L",
- &else_locus);
+ gfc_error ("ELSE IF statement at %C cannot follow ELSE "
+ "statement at %L", &else_locus);
reject_statement ();
break;
if (st == ST_CASE)
break;
- gfc_error
- ("Expected a CASE or END SELECT statement following SELECT CASE "
- "at %C");
+ gfc_error ("Expected a CASE or END SELECT statement following SELECT "
+ "CASE at %C");
reject_statement ();
}
case ST_END_SELECT:
break;
- /* Can't have an executable statement because of
- parse_executable(). */
+ /* Can't have an executable statement because of
+ parse_executable(). */
default:
unexpected_statement (st);
break;
if (p == gfc_state_stack)
return 1;
- gfc_error
- ("End of nonblock DO statement at %C is within another block");
+ gfc_error ("End of nonblock DO statement at %C is within another block");
return 2;
}
case ST_ENDDO:
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
- gfc_error_now
- ("Statement label in ENDDO at %C doesn't match DO label");
+ gfc_error_now ("Statement label in ENDDO at %C doesn't match "
+ "DO label");
if (gfc_statement_label != NULL)
{
name, but in that case we must have seen ST_ENDDO first).
We only complain about this in pedantic mode. */
if (gfc_current_block () != NULL)
- gfc_error_now
- ("named block DO at %L requires matching ENDDO name",
- &gfc_current_block()->declared_at);
+ gfc_error_now ("named block DO at %L requires matching ENDDO name",
+ &gfc_current_block()->declared_at);
break;
&& gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
{
/* In
- DO 100 I=1,10
- !$OMP DO
- DO J=1,10
- ...
- 100 CONTINUE
- there should be no !$OMP END DO. */
+ DO 100 I=1,10
+ !$OMP DO
+ DO J=1,10
+ ...
+ 100 CONTINUE
+ there should be no !$OMP END DO. */
pop_state ();
return ST_IMPLIED_ENDDO;
}
if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
|| (new_st.ext.omp_name != NULL
&& strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
- gfc_error ("Name after !$omp critical and !$omp end critical does"
- " not match at %C");
+ gfc_error ("Name after !$omp critical and !$omp end critical does "
+ "not match at %C");
gfc_free ((char *) new_st.ext.omp_name);
break;
case EXEC_OMP_END_SINGLE:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
- gfc_error
- ("%s statement at %C cannot terminate a non-block DO loop",
- gfc_ascii_statement (st));
+ gfc_error ("%s statement at %C cannot terminate a non-block "
+ "DO loop", gfc_ascii_statement (st));
break;
default:
the child namespace as the parser didn't know about this procedure. */
static void
-gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
+gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
{
gfc_namespace *ns;
gfc_symtree *st;
if ((old_sym->attr.flavor == FL_PROCEDURE
|| old_sym->ts.type == BT_UNKNOWN)
&& old_sym->ns == ns
- && ! old_sym->attr.contained)
- {
- /* Replace it with the symbol from the parent namespace. */
- st->n.sym = sym;
- sym->refs++;
-
- /* Free the old (local) symbol. */
- old_sym->refs--;
- if (old_sym->refs == 0)
- gfc_free_symbol (old_sym);
- }
+ && !old_sym->attr.contained)
+ {
+ /* Replace it with the symbol from the parent namespace. */
+ st->n.sym = sym;
+ sym->refs++;
+
+ /* Free the old (local) symbol. */
+ old_sym->refs--;
+ if (old_sym->refs == 0)
+ gfc_free_symbol (old_sym);
+ }
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
- gfc_error
- ("Contained procedure '%s' at %C is already ambiguous",
- gfc_new_block->name);
+ gfc_error ("Contained procedure '%s' at %C is already "
+ "ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
gfc_commit_symbols ();
}
- else
- sym = gfc_new_block;
+ else
+ sym = gfc_new_block;
- /* Mark this as a contained function, so it isn't replaced
- by other module functions. */
- sym->attr.contained = 1;
+ /* Mark this as a contained function, so it isn't replaced
+ by other module functions. */
+ sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
- /* Fix up any sibling functions that refer to this one. */
- gfc_fixup_sibling_symbols (sym, gfc_current_ns);
+ /* Fix up any sibling functions that refer to this one. */
+ gfc_fixup_sibling_symbols (sym, gfc_current_ns);
/* Or refer to any of its alternate entry points. */
for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
pop_state ();
break;
- /* These statements are associated with the end of the host
- unit. */
+ /* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_PROGRAM:
pop_state ();
if (!contains_statements)
/* This is valid in Fortran 2008. */
- gfc_notify_std (GFC_STD_GNU, "Extension: "
- "CONTAINS statement without FUNCTION "
- "or SUBROUTINE statement at %C");
+ gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
+ "FUNCTION or SUBROUTINE statement at %C");
}
{
if (blank_block)
gfc_error ("Blank BLOCK DATA at %C conflicts with "
- "prior BLOCK DATA at %L", &blank_locus);
+ "prior BLOCK DATA at %L", &blank_locus);
else
{
- blank_block = 1;
- blank_locus = gfc_current_locus;
+ blank_block = 1;
+ blank_locus = gfc_current_locus;
}
}
else
{
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
global_used(s, NULL);
else
{
- s->type = GSYM_BLOCK_DATA;
- s->where = gfc_current_locus;
+ s->type = GSYM_BLOCK_DATA;
+ s->where = gfc_current_locus;
s->defined = 1;
}
}
s = gfc_get_gsymbol(gfc_new_block->name);
if (s->defined
- || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ || (s->type != GSYM_UNKNOWN
+ && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol(gfc_current_ns);
+ main_program_symbol (gfc_current_ns);
parse_progunit (st);
break;
}
/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
A sign will be accepted if signflag is set. */
static match
-match_integer_constant (gfc_expr ** result, int signflag)
+match_integer_constant (gfc_expr **result, int signflag)
{
int length, kind;
locus old_loc;
/* Match a Hollerith constant. */
static match
-match_hollerith_constant (gfc_expr ** result)
+match_hollerith_constant (gfc_expr **result)
{
locus old_loc;
- gfc_expr * e = NULL;
- const char * msg;
- char * buffer;
+ gfc_expr *e = NULL;
+ const char *msg;
+ char *buffer;
int num;
int i;
gfc_gobble_whitespace ();
if (match_integer_constant (&e, 0) == MATCH_YES
- && gfc_match_char ('h') == MATCH_YES)
+ && gfc_match_char ('h') == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Extension: Hollerith constant at %C")
- == FAILURE)
+ if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
+ "at %C") == FAILURE)
goto cleanup;
msg = gfc_extract_int (e, &num);
}
if (num == 0)
{
- gfc_error ("Invalid Hollerith constant: %L must contain at least one "
- "character", &old_loc);
+ gfc_error ("Invalid Hollerith constant: %L must contain at least "
+ "one character", &old_loc);
goto cleanup;
}
if (e->ts.kind != gfc_default_integer_kind)
{
gfc_error ("Invalid Hollerith constant: Integer kind at %L "
- "should be default", &old_loc);
+ "should be default", &old_loc);
goto cleanup;
}
else
buffer[i] = gfc_next_char_literal (1);
}
gfc_free_expr (e);
- e = gfc_constant_result (BT_HOLLERITH,
- gfc_default_character_kind, &gfc_current_locus);
- e->value.character.string = gfc_getmem (num+1);
+ e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
+ e->value.character.string = gfc_getmem (num + 1);
memcpy (e->value.character.string, buffer, num);
e->value.character.string[num] = '\0';
e->value.character.length = num;
and 'a1...'z. An additional extension is the use of x for z. */
static match
-match_boz_constant (gfc_expr ** result)
+match_boz_constant (gfc_expr **result)
{
int post, radix, delim, length, x_hex, kind;
locus old_loc, start_loc;
is nonzero. Allow integer constants if allow_int is true. */
static match
-match_real_constant (gfc_expr ** result, int signflag)
+match_real_constant (gfc_expr **result, int signflag)
{
int kind, c, count, seen_dp, seen_digits, exp_char;
locus old_loc, temp_loc;
if (seen_dp)
goto done;
- /* Check to see if "." goes with a following operator like ".eq.". */
+ /* Check to see if "." goes with a following operator like
+ ".eq.". */
temp_loc = gfc_current_locus;
c = gfc_next_char ();
break;
}
- if (!seen_digits
- || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
case 'd':
if (kind != -2)
{
- gfc_error
- ("Real number at %C has a 'd' exponent and an explicit kind");
+ gfc_error ("Real number at %C has a 'd' exponent and an explicit "
+ "kind");
goto cleanup;
}
kind = gfc_default_double_kind;
case ARITH_UNDERFLOW:
if (gfc_option.warn_underflow)
- gfc_warning ("Real constant underflows its kind at %C");
+ gfc_warning ("Real constant underflows its kind at %C");
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
/* Match a substring reference. */
static match
-match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
+match_substring (gfc_charlen *cl, int init, gfc_ref **result)
{
gfc_expr *start, *end;
locus old_loc;
delimiter. Using match_kind_param() generates errors too quickly. */
static match
-match_string_constant (gfc_expr ** result)
+match_string_constant (gfc_expr **result)
{
char *p, name[GFC_MAX_SYMBOL_LEN + 1];
int i, c, kind, length, delimiter;
/* Match a .true. or .false. */
static match
-match_logical_constant (gfc_expr ** result)
+match_logical_constant (gfc_expr **result)
{
static mstring logical_ops[] = {
minit (".false.", 0),
symbolic constant. */
static match
-match_sym_complex_part (gfc_expr ** result)
+match_sym_complex_part (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
}
- *result = e; /* e is a scalar, real, constant expression */
+ *result = e; /* e is a scalar, real, constant expression. */
return MATCH_YES;
error:
/* Match a real or imaginary part of a complex number. */
static match
-match_complex_part (gfc_expr ** result)
+match_complex_part (gfc_expr **result)
{
match m;
/* Try to match a complex constant. */
static match
-match_complex_constant (gfc_expr ** result)
+match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
gfc_error_buf old_error;
match, zero for no match. */
match
-gfc_match_literal_constant (gfc_expr ** result, int signflag)
+gfc_match_literal_constant (gfc_expr **result, int signflag)
{
match m;
fixing things later during resolution. */
static match
-match_actual_arg (gfc_expr ** result)
+match_actual_arg (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *symtree;
/* Handle error elsewhere. */
/* Eliminate a couple of common cases where we know we don't
- have a function argument. */
+ have a function argument. */
if (symtree == NULL)
- {
+ {
gfc_get_sym_tree (name, NULL, &symtree);
- gfc_set_sym_referenced (symtree->n.sym);
- }
+ gfc_set_sym_referenced (symtree->n.sym);
+ }
else
{
- gfc_symbol *sym;
+ gfc_symbol *sym;
- sym = symtree->n.sym;
- gfc_set_sym_referenced (sym);
+ sym = symtree->n.sym;
+ gfc_set_sym_referenced (sym);
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
break;
/* Match a keyword argument. */
static match
-match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
+match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0)
{
- gfc_error
- ("Keyword '%s' at %C has already appeared in the current "
- "argument list", name);
+ gfc_error ("Keyword '%s' at %C has already appeared in the "
+ "current argument list", name);
return MATCH_ERROR;
}
}
switch (name[0])
{
case 'l':
- if (strncmp(name, "loc", 3) == 0)
+ if (strncmp (name, "loc", 3) == 0)
{
result->name = "%LOC";
break;
}
case 'r':
- if (strncmp(name, "ref", 3) == 0)
+ if (strncmp (name, "ref", 3) == 0)
{
result->name = "%REF";
break;
}
case 'v':
- if (strncmp(name, "val", 3) == 0)
+ if (strncmp (name, "val", 3) == 0)
{
result->name = "%VAL";
break;
we're matching the argument list of a subroutine. */
match
-gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
+gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
}
/* After the first keyword argument is seen, the following
- arguments must also have keywords. */
+ arguments must also have keywords. */
if (seen_keyword)
{
m = match_keyword_arg (tail, head);
goto cleanup;
if (m == MATCH_NO)
{
- gfc_error
- ("Missing keyword name in actual argument list at %C");
+ gfc_error ("Missing keyword name in actual argument list at %C");
goto cleanup;
}
element. */
static gfc_ref *
-extend_ref (gfc_expr * primary, gfc_ref * tail)
+extend_ref (gfc_expr *primary, gfc_ref *tail)
{
-
if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref ();
else
statement. */
static match
-match_varspec (gfc_expr * primary, int equiv_flag)
+match_varspec (gfc_expr *primary, int equiv_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
tail = NULL;
- if ((equiv_flag && gfc_peek_char () == '(')
- || sym->attr.dimension)
+ if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
- variables. We'll leave the decision till resolve
- time. */
+ variables. We'll leave the decision till resolve time. */
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
{
if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
{
- gfc_set_default_type (sym, 0, sym->ns);
- primary->ts = sym->ts;
+ gfc_set_default_type (sym, 0, sym->ns);
+ primary->ts = sym->ts;
}
}
We can have at most one full array reference. */
symbol_attribute
-gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
int dimension, pointer, allocatable, target;
symbol_attribute attr;
/* Return the attribute from a general expression. */
symbol_attribute
-gfc_expr_attr (gfc_expr * e)
+gfc_expr_attr (gfc_expr *e)
{
symbol_attribute attr;
attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this
- here. */
+ here. */
break;
seen. */
match
-gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
gfc_constructor *head, *tail;
gfc_component *comp;
{
if (comp->next == NULL)
{
- gfc_error
- ("Too many components in structure constructor at %C");
+ gfc_error ("Too many components in structure constructor at %C");
goto cleanup;
}
array reference, argument list of a function, etc. */
match
-gfc_match_rvalue (gfc_expr ** result)
+gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
/* See if this is a directly recursive function call. */
gfc_gobble_whitespace ();
if (sym->attr.recursive
- && gfc_peek_char () == '('
- && gfc_current_ns->proc_name == sym)
+ && gfc_peek_char () == '('
+ && gfc_current_ns->proc_name == sym)
{
if (!sym->attr.dimension)
goto function0;
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e);
break;
/* If we're here, then the name is known to be the name of a
}
/* At this point, the name has to be a non-statement function.
- If the name is the same as the current function being
- compiled, then we have a variable reference (to the function
- result) if the name is non-recursive. */
+ If the name is the same as the current function being
+ compiled, then we have a variable reference (to the function
+ result) if the name is non-recursive. */
st = gfc_enclosing_unit (NULL);
case FL_UNKNOWN:
/* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
+ via an IMPLICIT statement. This can't wait for the
+ resolution phase. */
if (gfc_peek_char () == '%'
&& sym->ts.type == BT_UNKNOWN
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
- variable. */
+ variable. */
if (sym->attr.dimension)
{
}
/* Name is not an array, so we peek to see if a '(' implies a
- function call or a substring reference. Otherwise the
- variable is just a scalar. */
+ function call or a substring reference. Otherwise the
+ variable is just a scalar. */
gfc_gobble_whitespace ();
if (gfc_peek_char () != '(')
}
/* If our new function returns a character, array or structure
- type, it might have subsequent references. */
+ type, it might have subsequent references. */
m = match_varspec (e, 0);
if (m == MATCH_NO)
match of the symbol to the local scope. */
static match
-match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
+match_variable (gfc_expr **result, int equiv_flag, int host_flag)
{
gfc_symbol *sym;
gfc_symtree *st;
{
case FL_VARIABLE:
if (sym->attr.protected && sym->attr.use_assoc)
- {
+ {
gfc_error ("Assigning to PROTECTED variable at %C");
- return MATCH_ERROR;
- }
+ return MATCH_ERROR;
+ }
break;
case FL_UNKNOWN:
return MATCH_YES;
}
+
match
-gfc_match_variable (gfc_expr ** result, int equiv_flag)
+gfc_match_variable (gfc_expr **result, int equiv_flag)
{
return match_variable (result, equiv_flag, 1);
}
+
match
-gfc_match_equiv_variable (gfc_expr ** result)
+gfc_match_equiv_variable (gfc_expr **result)
{
return match_variable (result, 1, 0);
}
/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
resort left for untyped names are the IMPLICIT types. */
static void
-resolve_formal_arglist (gfc_symbol * proc)
+resolve_formal_arglist (gfc_symbol *proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
if (sym == NULL)
{
- /* Alternate return placeholder. */
+ /* Alternate return placeholder. */
if (gfc_elemental (proc))
gfc_error ("Alternate return specifier in elemental subroutine "
"'%s' at %L is not allowed", proc->name,
&proc->declared_at);
- if (proc->attr.function)
- gfc_error ("Alternate return specifier in function "
- "'%s' at %L is not allowed", proc->name,
- &proc->declared_at);
+ if (proc->attr.function)
+ gfc_error ("Alternate return specifier in function "
+ "'%s' at %L is not allowed", proc->name,
+ &proc->declared_at);
continue;
}
{
if (gfc_pure (proc) && !gfc_pure (sym))
{
- gfc_error
- ("Dummy procedure '%s' of PURE procedure at %L must also "
- "be PURE", sym->name, &sym->declared_at);
+ gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
+ "also be PURE", sym->name, &sym->declared_at);
continue;
}
if (gfc_elemental (proc))
{
- gfc_error
- ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
- &sym->declared_at);
+ gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
+ "procedure", &sym->declared_at);
continue;
}
gfc_resolve_array_spec (sym->as, 0);
/* We can't tell if an array with dimension (:) is assumed or deferred
- shape until we know if it has the pointer or allocatable attributes.
+ shape until we know if it has the pointer or allocatable attributes.
*/
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable))
- {
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_int_expr (1);
- }
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ sym->as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < sym->as->rank; i++)
+ sym->as->lower[i] = gfc_int_expr (1);
+ }
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
- || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
- || sym->attr.optional)
- proc->attr.always_explicit = 1;
+ || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || sym->attr.optional)
+ proc->attr.always_explicit = 1;
/* If the flavor is unknown at this point, it has to be a variable.
- A procedure specification would have already set the type. */
+ A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc) && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ && sym->attr.flavor != FL_PROCEDURE)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
gfc_error ("Argument '%s' of pure function '%s' at %L must be "
{
if (sym->as != NULL)
{
- gfc_error
- ("Argument '%s' of elemental procedure at %L must be scalar",
- sym->name, &sym->declared_at);
+ gfc_error ("Argument '%s' of elemental procedure at %L must "
+ "be scalar", sym->name, &sym->declared_at);
continue;
}
if (sym->attr.pointer)
{
- gfc_error
- ("Argument '%s' of elemental procedure at %L cannot have "
- "the POINTER attribute", sym->name, &sym->declared_at);
+ gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+ "have the POINTER attribute", sym->name,
+ &sym->declared_at);
continue;
}
}
/* Each dummy shall be specified to be scalar. */
if (proc->attr.proc == PROC_ST_FUNCTION)
- {
- if (sym->as != NULL)
- {
- gfc_error
- ("Argument '%s' of statement function at %L must be scalar",
- sym->name, &sym->declared_at);
- continue;
- }
-
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl = sym->ts.cl;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error
- ("Character-valued argument '%s' of statement function at "
- "%L must have constant length",
- sym->name, &sym->declared_at);
- continue;
- }
- }
- }
+ {
+ if (sym->as != NULL)
+ {
+ gfc_error ("Argument '%s' of statement function at %L must "
+ "be scalar", sym->name, &sym->declared_at);
+ continue;
+ }
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Character-valued argument '%s' of statement "
+ "function at %L must have constant length",
+ sym->name, &sym->declared_at);
+ continue;
+ }
+ }
+ }
}
formal_arg_flag = 0;
}
associated with them. */
static void
-find_arglists (gfc_symbol * sym)
+find_arglists (gfc_symbol *sym)
{
-
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
return;
*/
static void
-resolve_formal_arglists (gfc_namespace * ns)
+resolve_formal_arglists (gfc_namespace *ns)
{
-
if (ns == NULL)
return;
static void
-resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
+resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
try t;
/* If this namespace is not a function, ignore it. */
- if (! sym
- || !(sym->attr.function
- || sym->attr.flavor == FL_VARIABLE))
+ if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
return;
/* Try to find out of what the return type is. */
}
}
- /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
- lists the only ways a character length value of * can be used: dummy arguments
- of procedures, named constants, and function results in external functions.
- Internal function results are not on that list; ergo, not permitted. */
+ /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
+ type, lists the only ways a character length value of * can be used:
+ dummy arguments of procedures, named constants, and function results
+ in external functions. Internal function results are not on that list;
+ ergo, not permitted. */
if (sym->ts.type == BT_CHARACTER)
{
symbol into an entry point. */
static void
-resolve_entries (gfc_namespace * ns)
+resolve_entries (gfc_namespace *ns)
{
gfc_namespace *old_ns;
gfc_code *c;
left in their own namespace, to keep prior references linked to
the entry declaration.*/
if (ns->proc_name->attr.function
- && ns->parent
- && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns;
/* Add an entry statement for it. */
{
sym = el->sym->result;
if (sym->attr.dimension)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be an array in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be an array in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be an array in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ }
else if (sym->attr.pointer)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be a POINTER in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be a POINTER in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ }
else
{
ts = &sym->ts;
break;
}
if (sym)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
- sym->name, gfc_typename (ts), ns->entries->sym->name,
- &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
- sym->name, gfc_typename (ts), ns->entries->sym->name,
- &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be of type %s "
+ "in FUNCTION %s at %L", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be of type %s "
+ "in FUNCTION %s at %L", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ }
}
}
}
in, not in a sibling or parent namespace. */
static void
-resolve_contained_functions (gfc_namespace * ns)
+resolve_contained_functions (gfc_namespace *ns)
{
gfc_namespace *child;
gfc_entry_list *el;
the types are correct. */
static try
-resolve_structure_cons (gfc_expr * expr)
+resolve_structure_cons (gfc_expr *expr)
{
gfc_constructor *cons;
gfc_component *comp;
for (; comp; comp = comp->next, cons = cons->next)
{
- if (! cons->expr)
+ if (!cons->expr)
continue;
if (gfc_resolve_expr (cons->expr) == FAILURE)
}
if (cons->expr->expr_type != EXPR_NULL
- && comp->as && comp->as->rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ && comp->as && comp->as->rank != cons->expr->rank
+ && (comp->allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
}
-
/****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or
attribute declaration statement, nonzero otherwise. */
static int
-was_declared (gfc_symbol * sym)
+was_declared (gfc_symbol *sym)
{
symbol_attribute a;
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
- || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
- || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
+ || a.optional || a.pointer || a.save || a.target || a.volatile_
+ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
return 0;
/* Determine if a symbol is generic or not. */
static int
-generic_sym (gfc_symbol * sym)
+generic_sym (gfc_symbol *sym)
{
gfc_symbol *s;
/* Determine if a symbol is specific or not. */
static int
-specific_sym (gfc_symbol * sym)
+specific_sym (gfc_symbol *sym)
{
gfc_symbol *s;
|| sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_INTERNAL
|| sym->attr.proc == PROC_ST_FUNCTION
- || (sym->attr.intrinsic &&
- gfc_specific_intrinsic (sym->name))
+ || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
|| sym->attr.external)
return 1;
proc_type;
static proc_type
-procedure_kind (gfc_symbol * sym)
+procedure_kind (gfc_symbol *sym)
{
-
if (generic_sym (sym))
return PTYPE_GENERIC;
static int need_full_assumed_size = 0;
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 last = 1;
- if (need_full_assumed_size
- || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+ if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
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)
{
switch (e->expr_type)
{
case EXPR_VARIABLE:
- if (e->symtree
- && check_assumed_size_reference (e->symtree->n.sym, e))
+ if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
return true;
break;
case EXPR_OP:
if (resolve_assumed_size_actual (e->value.op.op1)
- || resolve_assumed_size_actual (e->value.op.op2))
+ || resolve_assumed_size_actual (e->value.op.op2))
return true;
break;
references. */
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_symtree *parent_st;
{
e = arg->expr;
if (e == NULL)
- {
- /* Check the label is a valid branching target. */
- if (arg->label)
- {
- if (arg->label->defined == ST_LABEL_UNKNOWN)
- {
- gfc_error ("Label %d referenced at %L is never defined",
- arg->label->value, &arg->label->where);
- return FAILURE;
- }
- }
- continue;
- }
+ {
+ /* Check the label is a valid branching target. */
+ if (arg->label)
+ {
+ if (arg->label->defined == ST_LABEL_UNKNOWN)
+ {
+ gfc_error ("Label %d referenced at %L is never defined",
+ arg->label->value, &arg->label->where);
+ return FAILURE;
+ }
+ }
+ continue;
+ }
if (e->ts.type != BT_PROCEDURE)
{
goto argument_list;
}
- /* See if the expression node should really be a variable
- reference. */
+ /* See if the expression node should really be a variable reference. */
sym = e->symtree->n.sym;
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
if (!sym->attr.intrinsic
- && !(sym->attr.external || sym->attr.use_assoc
- || sym->attr.if_source == IFSRC_IFBODY)
- && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ && !(sym->attr.external || sym->attr.use_assoc
+ || sym->attr.if_source == IFSRC_IFBODY)
+ && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
"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)
{
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
+ "allowed as an actual argument at %L", sym->name,
&e->where);
}
if (sym->attr.generic)
{
gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
+ "allowed as an actual argument at %L", sym->name,
&e->where);
}
/* If all else fails, see if we have a specific intrinsic. */
if (sym->attr.function
- && sym->ts.type == BT_UNKNOWN
- && sym->attr.intrinsic)
+ && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name);
}
if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
- && e->ts.kind > gfc_default_real_kind)
- || (e->ts.kind > gfc_default_integer_kind))
+ && e->ts.kind > gfc_default_real_kind)
+ || (e->ts.kind > gfc_default_integer_kind))
{
gfc_error ("Kind of by-value argument at %L is larger "
"than default kind", &e->where);
/* Statement functions have already been excluded above. */
else if (strncmp ("%LOC", arg->name, 4) == 0
- && e->ts.type == BT_PROCEDURE)
+ && e->ts.type == BT_PROCEDURE)
{
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
{
/* 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
expr == NULL, we have a subroutine. */
+
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
if (expr && expr->value.function.actual != NULL)
{
if (expr->value.function.esym != NULL
- && expr->value.function.esym->attr.elemental)
+ && expr->value.function.esym->attr.elemental)
{
arg0 = expr->value.function.actual;
esym = expr->value.function.esym;
}
else if (expr->value.function.isym != NULL
- && expr->value.function.isym->elemental)
+ && expr->value.function.isym->elemental)
{
arg0 = expr->value.function.actual;
isym = expr->value.function.isym;
else
return SUCCESS;
}
- else if (c && c->ext.actual != NULL
- && c->symtree->n.sym->attr.elemental)
+ else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
{
arg0 = c->ext.actual;
esym = c->symtree->n.sym;
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->symtree->n.sym->attr.optional)
+ && arg->expr->symtree->n.sym->attr.optional)
set_by_optional = true;
/* Function specific; set the result rank and shape. */
formal_optional = true;
if (pedantic && arg->expr != NULL
- && arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->symtree->n.sym->attr.optional
- && formal_optional
- && arg->expr->rank
- && (set_by_optional || arg->expr->rank != rank)
- && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree->n.sym->attr.optional
+ && formal_optional
+ && arg->expr->rank
+ && (set_by_optional || arg->expr->rank != rank)
+ && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
{
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
"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)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
return FAILURE;
if (e != NULL)
{
if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
- == FAILURE)
+ == FAILURE)
return FAILURE;
}
else
function being called, or NULL if not known. */
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_expr *expr;
ap->expr->inline_noncopying_intrinsic = 1;
}
+
/* This function does the checking of references to global procedures
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
gsym->used = 1;
}
+
/************* Function resolution *************/
/* Resolve a function call known to be generic.
Section 14.1.2.4.1. */
static match
-resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
+resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
{
gfc_symbol *s;
if (sym->attr.generic)
{
- s =
- gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
+ s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
if (s != NULL)
{
expr->value.function.name = s->name;
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)
static try
-resolve_generic_f (gfc_expr * expr)
+resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
- gfc_error
- ("Generic function '%s' at %L is not consistent with a specific "
- "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
+ gfc_error ("Generic function '%s' at %L is not consistent with a "
+ "specific intrinsic interface", expr->symtree->n.sym->name,
+ &expr->where);
return FAILURE;
}
/* Resolve a function call known to be specific. */
static match
-resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
+resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{
match m;
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
- gfc_error
- ("Function '%s' at %L is INTRINSIC but is not compatible with "
- "an intrinsic", sym->name, &expr->where);
+ gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
+ "with an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
}
static try
-resolve_specific_f (gfc_expr * expr)
+resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
/* Resolve a procedure call not known to be generic nor specific. */
static try
-resolve_unknown_f (gfc_expr * expr)
+resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
gfc_typespec *ts;
function is PURE, zero if not. */
static int
-pure_function (gfc_expr * e, const char **name)
+pure_function (gfc_expr *e, const char **name)
{
int pure;
else if (e->value.function.isym)
{
pure = e->value.function.isym->pure
- || e->value.function.isym->elemental;
+ || e->value.function.isym->elemental;
*name = e->value.function.isym->name;
}
else
to INTENT(OUT) or INTENT(INOUT). */
static try
-resolve_function (gfc_expr * expr)
+resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
- gfc_symbol * sym;
+ gfc_symbol *sym;
const char *name;
try t;
int temp;
if (sym && sym->attr.flavor == FL_VARIABLE)
{
- gfc_error ("'%s' at %L is not a function",
- sym->name, &expr->where);
+ gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
return FAILURE;
}
/* If the procedure is not internal, a statement function or a module
procedure,it must be external and should be checked for usage. */
if (sym && !sym->attr.dummy && !sym->attr.contained
- && sym->attr.proc != PROC_ST_FUNCTION
- && !sym->attr.use_assoc)
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.use_assoc)
resolve_global_procedure (sym, &expr->where, 0);
/* Switch off assumed size checking and do this again for certain kinds
need_full_assumed_size--;
if (sym && sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && sym->ts.cl->length == NULL
- && !sym->attr.dummy
- && expr->value.function.esym == NULL
- && !sym->attr.contained)
+ && sym->ts.cl
+ && sym->ts.cl->length == NULL
+ && !sym->attr.dummy
+ && expr->value.function.esym == NULL
+ && !sym->attr.contained)
{
/* Internal procedures are taken care of in resolve_contained_fntype. */
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
return FAILURE;
}
-/* See if function is already resolved. */
+ /* See if function is already resolved. */
if (expr->value.function.name != NULL)
{
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
{
- gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
- " in WORKSHARE construct", expr->value.function.esym->name,
+ gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
+ "in WORKSHARE construct", expr->value.function.esym->name,
&expr->where);
t = FAILURE;
}
#define GENERIC_ID expr->value.function.isym->generic_id
else if (expr->value.function.actual != NULL
- && expr->value.function.isym != NULL
- && GENERIC_ID != GFC_ISYM_LBOUND
- && GENERIC_ID != GFC_ISYM_LEN
- && GENERIC_ID != GFC_ISYM_LOC
- && GENERIC_ID != GFC_ISYM_PRESENT)
+ && expr->value.function.isym != NULL
+ && GENERIC_ID != GFC_ISYM_LBOUND
+ && GENERIC_ID != GFC_ISYM_LEN
+ && GENERIC_ID != GFC_ISYM_LOC
+ && GENERIC_ID != GFC_ISYM_PRESENT)
{
/* Array intrinsics must also have the last upper bound of an
assumed size array argument. UBOUND and SIZE have to be
}
if (arg->expr != NULL
- && arg->expr->rank > 0
- && resolve_assumed_size_actual (arg->expr))
+ && arg->expr->rank > 0
+ && resolve_assumed_size_actual (arg->expr))
return FAILURE;
}
}
{
if (forall_flag)
{
- gfc_error
- ("reference to non-PURE function '%s' at %L inside a "
- "FORALL %s", name, &expr->where, forall_flag == 2 ?
- "mask" : "block");
+ gfc_error ("reference to non-PURE function '%s' at %L inside a "
+ "FORALL %s", name, &expr->where,
+ forall_flag == 2 ? "mask" : "block");
t = FAILURE;
}
else if (gfc_pure (NULL))
proc = gfc_current_ns->proc_name;
if (esym == proc)
{
- gfc_error ("Function '%s' at %L cannot call itself, as it is not "
- "RECURSIVE", name, &expr->where);
- t = FAILURE;
+ gfc_error ("Function '%s' at %L cannot call itself, as it is not "
+ "RECURSIVE", name, &expr->where);
+ t = FAILURE;
}
if (esym->attr.entry && esym->ns->entries && proc->ns->entries
- && esym->ns->entries->sym == proc->ns->entries->sym)
+ && esym->ns->entries->sym == proc->ns->entries->sym)
{
- gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
- "'%s' is not declared as RECURSIVE",
- esym->name, &expr->where, esym->ns->entries->sym->name);
- t = FAILURE;
+ gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
+ "'%s' is not declared as RECURSIVE",
+ esym->name, &expr->where, esym->ns->entries->sym->name);
+ t = FAILURE;
}
}
/************* Subroutine resolution *************/
static void
-pure_subroutine (gfc_code * c, gfc_symbol * sym)
+pure_subroutine (gfc_code *c, gfc_symbol *sym)
{
-
if (gfc_pure (sym))
return;
static match
-resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
+resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
{
gfc_symbol *s;
s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
if (s != NULL)
{
- c->resolved_sym = s;
+ c->resolved_sym = s;
pure_subroutine (c, s);
return MATCH_YES;
}
static try
-resolve_generic_s (gfc_code * c)
+resolve_generic_s (gfc_code *c)
{
gfc_symbol *sym;
match m;
if (!gfc_intrinsic_name (sym->name, 1))
{
- gfc_error
- ("There is no specific subroutine for the generic '%s' at %L",
- sym->name, &c->loc);
+ gfc_error ("There is no specific subroutine for the generic '%s' at %L",
+ sym->name, &c->loc);
return FAILURE;
}
/* Resolve a subroutine call known to be specific. */
static match
-resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
+resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
match m;
static try
-resolve_specific_s (gfc_code * c)
+resolve_specific_s (gfc_code *c)
{
gfc_symbol *sym;
match m;
/* Resolve a subroutine call not known to be generic nor specific. */
static try
-resolve_unknown_s (gfc_code * c)
+resolve_unknown_s (gfc_code *c)
{
gfc_symbol *sym;
makes things awkward. */
static try
-resolve_call (gfc_code * c)
+resolve_call (gfc_code *c)
{
try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
- && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ && c->symtree->n.sym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", c->symtree->n.sym->name,
/* If the procedure is not internal or module, it must be external and
should be checked for usage. */
if (c->symtree && c->symtree->n.sym
- && !c->symtree->n.sym->attr.dummy
- && !c->symtree->n.sym->attr.contained
- && !c->symtree->n.sym->attr.use_assoc)
+ && !c->symtree->n.sym->attr.dummy
+ && !c->symtree->n.sym->attr.contained
+ && !c->symtree->n.sym->attr.use_assoc)
resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
proc = gfc_current_ns->proc_name;
if (csym == proc)
{
- gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
- "RECURSIVE", csym->name, &c->loc);
- t = FAILURE;
+ gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
+ "RECURSIVE", csym->name, &c->loc);
+ t = FAILURE;
}
if (csym->attr.entry && csym->ns->entries && proc->ns->entries
- && csym->ns->entries->sym == proc->ns->entries->sym)
+ && csym->ns->entries->sym == proc->ns->entries->sym)
{
- gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
- "'%s' is not declared as RECURSIVE",
- csym->name, &c->loc, csym->ns->entries->sym->name);
- t = FAILURE;
+ gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
+ "'%s' is not declared as RECURSIVE",
+ csym->name, &c->loc, csym->ns->entries->sym->name);
+ t = FAILURE;
}
}
/* Resume assumed_size checking. */
need_full_assumed_size--;
-
t = SUCCESS;
if (c->resolved_sym == NULL)
switch (procedure_kind (c->symtree->n.sym))
return t;
}
+
/* 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
match. If both op1->shape and op2->shape are non-NULL return FAILURE
NULL, return SUCCESS. */
static try
-compare_shapes (gfc_expr * op1, gfc_expr * op2)
+compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
try t;
int i;
return t;
}
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
static try
-resolve_operator (gfc_expr * e)
+resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
char msg[200];
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_kind_max (op1, op2);
- if (op1->ts.kind < e->ts.kind)
- gfc_convert_type (op1, &e->ts, 2);
- else if (op2->ts.kind < e->ts.kind)
- gfc_convert_type (op2, &e->ts, 2);
+ if (op1->ts.kind < e->ts.kind)
+ gfc_convert_type (op1, &e->ts, 2);
+ else if (op2->ts.kind < e->ts.kind)
+ gfc_convert_type (op2, &e->ts, 2);
break;
}
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
- _("Logicals at %%L must be compared with %s instead of %s"),
+ _("Logicals at %%L must be compared with %s instead of %s"),
e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
gfc_op2string (e->value.op.operator));
else
sprintf (msg,
- _("Operands of comparison operator '%s' at %%L are %s/%s"),
+ _("Operands of comparison operator '%s' at %%L are %s/%s"),
gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
&op1->where, &op2->where);
t = FAILURE;
- /* Allow higher level expressions to work. */
+ /* Allow higher level expressions to work. */
e->rank = 0;
}
}
/************** Array resolution subroutines **************/
-
typedef enum
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
comparison;
/* Compare two integer expressions. */
static comparison
-compare_bound (gfc_expr * a, gfc_expr * b)
+compare_bound (gfc_expr *a, gfc_expr *b)
{
int i;
/* Compare an integer expression with an integer. */
static comparison
-compare_bound_int (gfc_expr * a, int b)
+compare_bound_int (gfc_expr *a, int b)
{
int i;
/* Compare an integer expression with a mpz_t. */
static comparison
-compare_bound_mpz_t (gfc_expr * a, mpz_t b)
+compare_bound_mpz_t (gfc_expr *a, mpz_t b)
{
int i;
sequence if empty, and 1 otherwise. */
static int
-compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
- gfc_expr * stride, mpz_t last)
+compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
+ gfc_expr *stride, mpz_t last)
{
mpz_t rem;
specification. */
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;
/* Compare an array reference with an array specification. */
static try
-compare_spec_to_ref (gfc_array_ref * ar)
+compare_spec_to_ref (gfc_array_ref *ar)
{
gfc_array_spec *as;
int i;
/* TODO: Full array sections are only allowed as actual parameters. */
if (as->type == AS_ASSUMED_SIZE
&& (/*ar->type == AR_FULL
- ||*/ (ar->type == AR_SECTION
- && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
+ ||*/ (ar->type == AR_SECTION
+ && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
{
- gfc_error ("Rightmost upper bound of assumed size array section"
- " not specified at %L", &ar->where);
+ gfc_error ("Rightmost upper bound of assumed size array section "
+ "not specified at %L", &ar->where);
return FAILURE;
}
/* Resolve one part of an array index. */
try
-gfc_resolve_index (gfc_expr * index, int check_scalar)
+gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
provide an additional array specification. */
static void
-find_array_spec (gfc_expr * e)
+find_array_spec (gfc_expr *e)
{
gfc_array_spec *as;
gfc_component *c;
/* Resolve an array reference. */
static try
-resolve_array_ref (gfc_array_ref * ar)
+resolve_array_ref (gfc_array_ref *ar)
{
int i, check_scalar;
gfc_expr *e;
case 1:
ar->dimen_type[i] = DIMEN_VECTOR;
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->ts.type == BT_DERIVED)
+ && e->symtree->n.sym->ts.type == BT_DERIVED)
ar->start[i] = gfc_get_parentheses (e);
break;
static try
-resolve_substring (gfc_ref * ref)
+resolve_substring (gfc_ref *ref)
{
-
if (ref->u.ss.start != NULL)
{
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
/* Resolve subtype references. */
static try
-resolve_ref (gfc_expr * expr)
+resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
gfc_ref *ref;
if (current_part_dimension || seen_part_dimension)
{
if (ref->u.c.component->pointer)
- {
- gfc_error
- ("Component to the right of a part reference with nonzero "
- "rank must not have the POINTER attribute at %L",
- &expr->where);
+ {
+ gfc_error ("Component to the right of a part reference "
+ "with nonzero rank must not have the POINTER "
+ "attribute at %L", &expr->where);
return FAILURE;
}
else if (ref->u.c.component->allocatable)
- {
- gfc_error
- ("Component to the right of a part reference with nonzero "
- "rank must not have the ALLOCATABLE attribute at %L",
- &expr->where);
+ {
+ gfc_error ("Component to the right of a part reference "
+ "with nonzero rank must not have the ALLOCATABLE "
+ "attribute at %L", &expr->where);
return FAILURE;
}
}
if (((ref->type == REF_COMPONENT && n_components > 1)
|| ref->next == NULL)
- && current_part_dimension
+ && current_part_dimension
&& seen_part_dimension)
{
-
gfc_error ("Two or more part references with nonzero rank must "
"not be specified at %L", &expr->where);
return FAILURE;
if (current_part_dimension)
seen_part_dimension = 1;
- /* reset to make sure */
+ /* reset to make sure */
current_part_dimension = 0;
}
}
Leaves the shape array NULL if it is not possible to determine the shape. */
static void
-expression_shape (gfc_expr * e)
+expression_shape (gfc_expr *e)
{
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
examining the base symbol and any reference structures it may have. */
static void
-expression_rank (gfc_expr * e)
+expression_rank (gfc_expr *e)
{
gfc_ref *ref;
int i, rank;
}
e->rank = (e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank;
+ ? 0 : e->symtree->n.sym->as->rank;
goto done;
}
if (ref->u.ar.type == AR_SECTION)
{
- /* Figure out the rank of the section. */
+ /* Figure out the rank of the section. */
if (rank != 0)
gfc_internal_error ("expression_rank(): Two array specs");
/* Resolve a variable expression. */
static try
-resolve_variable (gfc_expr * e)
+resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
try t;
/* Deal with forward references to entries during resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
- && current_entry_id == sym->entry_id
- && cs_base
- && cs_base->current
- && cs_base->current->op != EXEC_ENTRY)
+ && current_entry_id == sym->entry_id
+ && cs_base
+ && cs_base->current
+ && cs_base->current->op != EXEC_ENTRY)
{
gfc_entry_list *entry;
gfc_formal_arglist *formal;
/* Now do the same check on the specification expressions. */
specification_expr = 1;
if (sym->ts.type == BT_CHARACTER
- && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
+ && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
t = FAILURE;
if (sym->as)
for overloaded types and unresolved function references are resolved. */
try
-gfc_resolve_expr (gfc_expr * e)
+gfc_resolve_expr (gfc_expr *e)
{
try t;
gfc_expand_constructor (e);
}
- /* This provides the opportunity for the length of constructors with character
- valued function elements to propogate the string length to the expression. */
+ /* This provides the opportunity for the length of constructors with
+ character valued function elements to propogate the string length
+ to the expression. */
if (e->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (e);
+ gfc_resolve_character_array_constructor (e);
break;
INTEGER or (optionally) REAL type. */
static try
-gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
- const char * name_msgid)
+gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
+ const char *name_msgid)
{
if (gfc_resolve_expr (expr) == FAILURE)
return FAILURE;
false allow only INTEGER type iterators, otherwise allow REAL types. */
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)
- gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: REAL DO loop iterator at %L",
+ gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: REAL DO loop iterator at %L",
&iter->var->where);
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
INTEGERs, and if stride is a constant it must be nonzero. */
static void
-resolve_forall_iterators (gfc_forall_iterator * iter)
+resolve_forall_iterators (gfc_forall_iterator *iter)
{
-
while (iter)
{
if (gfc_resolve_expr (iter->var) == SUCCESS
{
if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
gfc_error ("FORALL stride expression at %L must be a scalar %s",
- &iter->stride->where, "INTEGER");
+ &iter->stride->where, "INTEGER");
if (iter->stride->expr_type == EXPR_CONSTANT
&& mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
Returns zero if no pointer components are found, nonzero otherwise. */
static int
-derived_pointer (gfc_symbol * sym)
+derived_pointer (gfc_symbol *sym)
{
gfc_component *c;
for (c = sym->components; c; c = c->next)
{
- if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
- return 1;
+ if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
+ return 1;
}
return 0;
a pointer or a full array. */
static try
-resolve_deallocate_expr (gfc_expr * e)
+resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
for (ref = e->ref; ref; ref = ref->next)
{
if (pointer)
- check_intent_in = 0;
+ check_intent_in = 0;
switch (ref->type)
- {
- case REF_ARRAY:
+ {
+ case REF_ARRAY:
if (ref->u.ar.type != AR_FULL)
allocatable = 0;
break;
- case REF_COMPONENT:
+ case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
+ && ref->u.c.component->as->type == AS_DEFERRED);
pointer = ref->u.c.component->pointer;
break;
- case REF_SUBSTRING:
+ case REF_SUBSTRING:
allocatable = 0;
break;
- }
+ }
}
attr = gfc_expr_attr (e);
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ e->symtree->n.sym->name, &e->where);
return FAILURE;
}
return SUCCESS;
}
+
/* Returns true if the expression e contains a reference the symbol sym. */
static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ rv = rv
+ || find_sym_in_expr (sym,
+ ref->u.c.component->ts.cl->length);
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 || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
+ rv = rv
+ || 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;
}
components that need nullification.) */
static gfc_expr *
-expr_to_initialize (gfc_expr * e)
+expr_to_initialize (gfc_expr *e)
{
gfc_expr *result;
gfc_ref *ref;
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
- ref->u.ar.type = AR_FULL;
+ ref->u.ar.type = AR_FULL;
- for (i = 0; i < ref->u.ar.dimen; i++)
- ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
- result->rank = ref->u.ar.dimen;
- break;
+ result->rank = ref->u.ar.dimen;
+ break;
}
return result;
have a trailing array reference that gives the size of the array. */
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;
symbol_attribute attr;
if (e->expr_type != EXPR_VARIABLE)
{
allocatable = 0;
-
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
-
}
else
{
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
- {
+ {
if (pointer)
check_intent_in = 0;
switch (ref->type)
{
case REF_ARRAY:
- if (ref->next != NULL)
- pointer = 0;
- break;
+ if (ref->next != NULL)
+ pointer = 0;
+ break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
+ allocatable = (ref->u.c.component->as != NULL
+ && ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
- dimension = ref->u.c.component->dimension;
- break;
+ pointer = ref->u.c.component->pointer;
+ dimension = ref->u.c.component->dimension;
+ break;
case REF_SUBSTRING:
- allocatable = 0;
- pointer = 0;
- break;
+ allocatable = 0;
+ pointer = 0;
+ break;
}
}
}
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ e->symtree->n.sym->name, &e->where);
return FAILURE;
}
/* Add default initializer for those derived types that need them. */
if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
{
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr = expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
+ init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr = expr_to_initialize (e);
+ init_st->expr2 = init_e;
+ init_st->next = code->next;
+ code->next = init_st;
}
if (pointer && dimension == 0)
There are nine situations to check. */
static int
-compare_cases (const gfc_case * op1, const gfc_case * op2)
+compare_cases (const gfc_case *op1, const gfc_case *op2)
{
int retval;
retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
- else /* op2 = (M:N) */
- {
+ else /* op2 = (M:N) */
+ {
retval = 0;
- /* L < M */
+ /* L < M */
if (gfc_compare_expr (op1->high, op2->low) < 0)
retval = -1;
- /* K > N */
+ /* K > N */
else if (gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
overlap, or NULL otherwise. */
static gfc_case *
-check_case_overlap (gfc_case * list)
+check_case_overlap (gfc_case *list)
{
gfc_case *p, *q, *e, *tail;
int insize, nmerges, psize, qsize, cmp, overlap_seen;
nmerges++;
/* Cut the list in two pieces by stepping INSIZE places
- forward in the list, starting from P. */
+ forward in the list, starting from P. */
psize = 0;
q = p;
for (i = 0; i < insize; i++)
/* Now we have two lists. Merge them! */
while (psize > 0 || (qsize > 0 && q != NULL))
{
-
/* See from which the next case to merge comes from. */
if (psize == 0)
{
if (cmp < 0)
{
/* The whole case range for P is less than the
- one for Q. */
+ one for Q. */
e = p;
p = p->right;
psize--;
else if (cmp > 0)
{
/* The whole case range for Q is greater than
- the case range for P. */
+ the case range for P. */
e = q;
q = q->right;
qsize--;
}
/* P has now stepped INSIZE places along, and so has Q. So
- they're the same. */
+ they're the same. */
p = q;
}
tail->right = NULL;
/* If we have done only one merge or none at all, we've
- finished sorting the cases. */
+ finished sorting the cases. */
if (nmerges <= 1)
- {
+ {
if (!overlap_seen)
return list;
else
type. Return FAILURE if anything is wrong. */
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 (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
- &e->where, case_expr->ts.kind);
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
expression. */
static void
-resolve_select (gfc_code * code)
+resolve_select (gfc_code *code)
{
gfc_code *body;
gfc_expr *case_expr;
{
/* This was actually a computed GOTO statement. */
case_expr = code->expr2;
- if (case_expr->ts.type != BT_INTEGER
- || case_expr->rank != 0)
+ if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
gfc_error ("Selection expression in computed GOTO statement "
"at %L must be a scalar integer expression",
&case_expr->where);
seen_unreachable = 0;
/* Walk the case label list, making sure that all case labels
- are legal. */
+ are legal. */
for (cp = body->ext.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
if (cp->low == NULL && cp->high == NULL)
{
if (default_case != NULL)
- {
+ {
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &cp->where);
}
/* Deal with single value cases and case ranges. Errors are
- issued from the validation function. */
+ issued from the validation function. */
if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
|| validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
&& ((cp->low == NULL || cp->high == NULL)
|| cp->low != cp->high))
{
- gfc_error
- ("Logical range in CASE statement at %L is not allowed",
- &cp->low->where);
+ gfc_error ("Logical range in CASE statement at %L is not "
+ "allowed", &cp->low->where);
t = FAILURE;
break;
}
&& gfc_compare_expr (cp->low, cp->high) > 0)
{
if (gfc_option.warn_surprising)
- gfc_warning ("Range specification at %L can never "
+ gfc_warning ("Range specification at %L can never "
"be matched", &cp->where);
cp->unreachable = 1;
double linked list here. We sort that with a merge sort
later on to detect any overlapping cases. */
if (!head)
- {
+ {
head = tail = cp;
head->right = head->left = NULL;
}
else
- {
+ {
tail->right = cp;
tail->right->left = tail;
tail = tail->right;
for (body = code; body && body->block; body = body->block)
{
if (body->block->ext.case_list == NULL)
- {
+ {
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
body->block = c->block;
/* Kill the dead block, but not the blocks below it. */
c->block = NULL;
gfc_free_statements (c);
- }
+ }
}
/* More than two cases is legal but insane for logical selects.
-- we're not trying to transfer a whole assumed size array. */
static void
-resolve_transfer (gfc_code * code)
+resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
gfc_symbol *sym;
exp = code->expr;
- if (exp->expr_type != EXPR_VARIABLE
- && exp->expr_type != EXPR_FUNCTION)
+ if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
return;
sym = exp->symtree->n.sym;
The code node described where the branch is located. */
static void
-resolve_branch (gfc_st_label * label, gfc_code * code)
+resolve_branch (gfc_st_label *label, gfc_code *code)
{
gfc_code *block, *found;
code_stack *stack;
/* The label is not in an enclosing block, so illegal. This was
allowed in Fortran 66, so we allow it as extension. We also
forego further checks if we run into this. */
- gfc_notify_std (GFC_STD_LEGACY,
- "Label at %L is not in the same block as the "
- "GOTO statement at %L", &lp->where, &code->loc);
+ gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
+ "as the GOTO statement at %L", &lp->where, &code->loc);
return;
}
break;
if (stack == NULL)
- gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: GOTO at %L jumps to END of construct at %L",
- &code->loc, &found->loc);
+ gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to END "
+ "of construct at %L", &code->loc, &found->loc);
}
}
for (i=0; i<expr1->rank; i++)
{
if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
- goto ignore;
+ goto ignore;
if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
- goto ignore;
+ goto ignore;
if (mpz_cmp (shape[i], shape2[i]))
- goto over;
+ goto over;
}
/* When either of the two expression is an assumed size array, we
result = SUCCESS;
over:
- for (i--; i>=0; i--)
+ for (i--; i >= 0; i--)
{
mpz_clear (shape[i]);
mpz_clear (shape2[i]);
while (cblock)
{
if (cblock->expr)
- {
- /* Check if the mask-expr has a consistent shape with the
- outmost WHERE mask-expr. */
- if (resolve_where_shape (cblock->expr, e) == FAILURE)
- gfc_error ("WHERE mask at %L has inconsistent shape",
- &cblock->expr->where);
- }
+ {
+ /* Check if the mask-expr has a consistent shape with the
+ outmost WHERE mask-expr. */
+ if (resolve_where_shape (cblock->expr, e) == FAILURE)
+ gfc_error ("WHERE mask at %L has inconsistent shape",
+ &cblock->expr->where);
+ }
/* the assignment statement of a WHERE statement, or the first
- statement in where-body-construct of a WHERE construct */
+ statement in where-body-construct of a WHERE construct */
cnext = cblock->next;
while (cnext)
- {
- switch (cnext->op)
- {
- /* WHERE assignment statement */
- case EXEC_ASSIGN:
-
- /* Check shape consistent for WHERE assignment target. */
- if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
- gfc_error ("WHERE assignment target at %L has "
- "inconsistent shape", &cnext->expr->where);
- break;
-
- /* WHERE or WHERE construct is part of a where-body-construct */
- case EXEC_WHERE:
- resolve_where (cnext, e);
- break;
-
- default:
- gfc_error ("Unsupported statement inside WHERE at %L",
- &cnext->loc);
- }
- /* the next statement within the same where-body-construct */
- cnext = cnext->next;
+ {
+ switch (cnext->op)
+ {
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN:
+
+ /* Check shape consistent for WHERE assignment target. */
+ if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
+ gfc_error ("WHERE assignment target at %L has "
+ "inconsistent shape", &cnext->expr->where);
+ break;
+
+ /* WHERE or WHERE construct is part of a where-body-construct */
+ case EXEC_WHERE:
+ resolve_where (cnext, e);
+ break;
+
+ default:
+ gfc_error ("Unsupported statement inside WHERE at %L",
+ &cnext->loc);
+ }
+ /* the next statement within the same where-body-construct */
+ cnext = cnext->next;
}
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
cblock = cblock->block;
/* A scalar assignment */
if (!expr->ref)
- {
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- else
- return FAILURE;
- }
+ {
+ if (expr->symtree->n.sym == symbol)
+ return SUCCESS;
+ else
+ return FAILURE;
+ }
/* the expr is array ref, substring or struct component. */
tmp = expr->ref;
while (tmp != NULL)
- {
- switch (tmp->type)
- {
- case REF_ARRAY:
- /* Check if the symbol appears in the array subscript. */
- ar = tmp->u.ar;
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- if (ar.start[i])
- if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.end[i])
- if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.stride[i])
- if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
- return SUCCESS;
- } /* end for */
- break;
-
- case REF_SUBSTRING:
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- tmp = expr->ref;
- /* Check if the symbol appears in the substring section. */
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- break;
-
- case REF_COMPONENT:
- break;
-
- default:
- gfc_error("expression reference type error at %L", &expr->where);
- }
- tmp = tmp->next;
- }
+ {
+ switch (tmp->type)
+ {
+ case REF_ARRAY:
+ /* Check if the symbol appears in the array subscript. */
+ ar = tmp->u.ar;
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ if (ar.start[i])
+ if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
+ return SUCCESS;
+
+ if (ar.end[i])
+ if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
+ return SUCCESS;
+
+ if (ar.stride[i])
+ if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
+ return SUCCESS;
+ } /* end for */
+ break;
+
+ case REF_SUBSTRING:
+ if (expr->symtree->n.sym == symbol)
+ return SUCCESS;
+ tmp = expr->ref;
+ /* Check if the symbol appears in the substring section. */
+ if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
+ return SUCCESS;
+ if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
+ return SUCCESS;
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ default:
+ gfc_error("expression reference type error at %L", &expr->where);
+ }
+ tmp = tmp->next;
+ }
break;
/* If the expression is a function call, then check if the symbol
appears in the actual arglist of the function. */
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
- {
- if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
- return SUCCESS;
- }
+ {
+ if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
/* It seems not to happen. */
case EXPR_SUBSTRING:
if (expr->ref)
- {
- tmp = expr->ref;
- gcc_assert (expr->ref->type == REF_SUBSTRING);
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- }
+ {
+ tmp = expr->ref;
+ gcc_assert (expr->ref->type == REF_SUBSTRING);
+ if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
+ return SUCCESS;
+ if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
/* It seems not to happen. */
case EXPR_STRUCTURE:
case EXPR_ARRAY:
gfc_error ("Unsupported statement while finding forall index in "
- "expression");
+ "expression");
break;
case EXPR_OP:
forall_index = var_expr[n]->symtree->n.sym;
/* Check whether the assignment target is one of the FORALL index
- variable. */
+ variable. */
if ((code->expr->expr_type == EXPR_VARIABLE)
- && (code->expr->symtree->n.sym == forall_index))
- gfc_error ("Assignment to a FORALL index variable at %L",
- &code->expr->where);
+ && (code->expr->symtree->n.sym == forall_index))
+ gfc_error ("Assignment to a FORALL index variable at %L",
+ &code->expr->where);
else
- {
- /* If one of the FORALL index variables doesn't appear in the
- assignment target, then there will be a many-to-one
- assignment. */
- if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
- gfc_error ("The FORALL with index '%s' cause more than one "
- "assignment to this object at %L",
- var_expr[n]->symtree->name, &code->expr->where);
- }
+ {
+ /* If one of the FORALL index variables doesn't appear in the
+ assignment target, then there will be a many-to-one
+ assignment. */
+ if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
+ gfc_error ("The FORALL with index '%s' cause more than one "
+ "assignment to this object at %L",
+ var_expr[n]->symtree->name, &code->expr->where);
+ }
}
}
/* Resolve WHERE statement in FORALL construct. */
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 *cnext;
while (cblock)
{
/* the assignment statement of a WHERE statement, or the first
- statement in where-body-construct of a WHERE construct */
+ statement in where-body-construct of a WHERE construct */
cnext = cblock->next;
while (cnext)
- {
- switch (cnext->op)
- {
- /* WHERE assignment statement */
- case EXEC_ASSIGN:
- gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
- break;
-
- /* WHERE or WHERE construct is part of a where-body-construct */
- case EXEC_WHERE:
- gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
- break;
-
- default:
- gfc_error ("Unsupported statement inside WHERE at %L",
- &cnext->loc);
- }
- /* the next statement within the same where-body-construct */
- cnext = cnext->next;
- }
+ {
+ switch (cnext->op)
+ {
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN:
+ gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+ break;
+
+ /* WHERE or WHERE construct is part of a where-body-construct */
+ case EXEC_WHERE:
+ gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
+ break;
+
+ default:
+ gfc_error ("Unsupported statement inside WHERE at %L",
+ &cnext->loc);
+ }
+ /* the next statement within the same where-body-construct */
+ cnext = cnext->next;
+ }
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
cblock = cblock->block;
}
while (c)
{
switch (c->op)
- {
- case EXEC_ASSIGN:
- case EXEC_POINTER_ASSIGN:
- gfc_resolve_assign_in_forall (c, nvar, var_expr);
- break;
-
- /* Because the gfc_resolve_blocks() will handle the nested FORALL,
- there is no need to handle it here. */
- case EXEC_FORALL:
- break;
- case EXEC_WHERE:
- gfc_resolve_where_code_in_forall(c, nvar, var_expr);
- break;
- default:
- break;
- }
+ {
+ case EXEC_ASSIGN:
+ case EXEC_POINTER_ASSIGN:
+ gfc_resolve_assign_in_forall (c, nvar, var_expr);
+ break;
+
+ /* Because the gfc_resolve_blocks() will handle the nested FORALL,
+ there is no need to handle it here. */
+ case EXEC_FORALL:
+ break;
+ case EXEC_WHERE:
+ gfc_resolve_where_code_in_forall(c, nvar, var_expr);
+ break;
+ default:
+ break;
+ }
/* The next statement in the FORALL body. */
c = c->next;
}
if (forall_save == 0)
{
/* Count the total number of FORALL index in the nested FORALL
- construct in order to allocate the VAR_EXPR with proper size. */
+ construct in order to allocate the VAR_EXPR with proper size. */
next = code;
while ((next != NULL) && (next->op == EXEC_FORALL))
- {
- for (fa = next->ext.forall_iterator; fa; fa = fa->next)
- total_var ++;
- next = next->block->next;
- }
+ {
+ for (fa = next->ext.forall_iterator; fa; fa = fa->next)
+ total_var ++;
+ next = next->block->next;
+ }
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
{
/* Check if any outer FORALL index name is the same as the current
- one. */
+ one. */
for (i = 0; i < nvar; i++)
- {
- if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
- {
- gfc_error ("An outer FORALL construct already has an index "
- "with this name %L", &fa->var->where);
- }
- }
+ {
+ if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
+ {
+ gfc_error ("An outer FORALL construct already has an index "
+ "with this name %L", &fa->var->where);
+ }
+ }
/* Record the current FORALL index. */
var_expr[nvar] = gfc_copy_expr (fa->var);
/* Check if the FORALL index appears in start, end or stride. */
if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->start->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->start->where);
if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->end->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->end->where);
if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->stride->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->stride->where);
nvar++;
}
static void resolve_code (gfc_code *, gfc_namespace *);
void
-gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
+gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
try t;
case EXEC_IF:
if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
- gfc_error
- ("IF clause at %L requires a scalar LOGICAL expression",
- &b->expr->where);
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &b->expr->where);
break;
case EXEC_WHERE:
if (t == SUCCESS
&& b->expr != NULL
- && (b->expr->ts.type != BT_LOGICAL
- || b->expr->rank == 0))
- gfc_error
- ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
- &b->expr->where);
+ && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
+ gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
+ &b->expr->where);
break;
- case EXEC_GOTO:
- resolve_branch (b->label, b);
- break;
+ case EXEC_GOTO:
+ resolve_branch (b->label, b);
+ break;
case EXEC_SELECT:
case EXEC_FORALL:
code block. */
static void
-resolve_code (gfc_code * code, gfc_namespace * ns)
+resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save;
break;
case EXEC_GOTO:
- if (code->expr != NULL)
+ if (code->expr != NULL)
{
if (code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
- "variable", &code->expr->where);
+ gfc_error ("ASSIGNED GOTO statement at %L requires an "
+ "INTEGER variable", &code->expr->where);
else if (code->expr->symtree->n.sym->attr.assign != 1)
- gfc_error ("Variable '%s' has not been assigned a target label "
- "at %L", code->expr->symtree->n.sym->name,
- &code->expr->where);
+ gfc_error ("Variable '%s' has not been assigned a target "
+ "label at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
}
else
- resolve_branch (code->label, code);
+ resolve_branch (code->label, code);
break;
case EXEC_RETURN:
}
if (code->expr->ts.type == BT_CHARACTER
- && gfc_option.warn_character_truncation)
+ && gfc_option.warn_character_truncation)
{
int llen = 0, rlen = 0;
if (code->expr->ts.cl != NULL
- && code->expr->ts.cl->length != NULL
- && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && code->expr->ts.cl->length != NULL
+ && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
if (code->expr2->expr_type == EXPR_CONSTANT)
rlen = code->expr2->value.character.length;
else if (code->expr2->ts.cl != NULL
- && code->expr2->ts.cl->length != NULL
- && code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && code->expr2->ts.cl->length != NULL
+ && code->expr2->ts.cl->length->expr_type
+ == EXPR_CONSTANT)
rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen)
- gfc_warning_now ("rhs of CHARACTER assignment at %L will "
- "be truncated (%d/%d)", &code->loc, rlen, llen);
+ gfc_warning_now ("rhs of CHARACTER assignment at %L will be "
+ "truncated (%d/%d)", &code->loc, rlen, llen);
}
if (gfc_pure (NULL))
{
if (gfc_impure_variable (code->expr->symtree->n.sym))
{
- gfc_error
- ("Cannot assign to variable '%s' in PURE procedure at %L",
- code->expr->symtree->n.sym->name, &code->expr->where);
+ gfc_error ("Cannot assign to variable '%s' in PURE "
+ "procedure at %L",
+ code->expr->symtree->n.sym->name,
+ &code->expr->where);
break;
}
if (code->expr2->ts.type == BT_DERIVED
&& derived_pointer (code->expr2->ts.derived))
{
- gfc_error
- ("Right side of assignment at %L is a derived type "
- "containing a POINTER in a PURE procedure",
- &code->expr2->where);
+ gfc_error ("Right side of assignment at %L is a derived "
+ "type containing a POINTER in a PURE procedure",
+ &code->expr2->where);
break;
}
}
break;
case EXEC_LABEL_ASSIGN:
- if (code->label->defined == ST_LABEL_UNKNOWN)
- gfc_error ("Label %d referenced at %L is never defined",
- code->label->value, &code->label->where);
- if (t == SUCCESS
+ if (code->label->defined == ST_LABEL_UNKNOWN)
+ gfc_error ("Label %d referenced at %L is never defined",
+ code->label->value, &code->label->where);
+ if (t == SUCCESS
&& (code->expr->expr_type != EXPR_VARIABLE
|| code->expr->symtree->n.sym->ts.type != BT_INTEGER
|| code->expr->symtree->n.sym->ts.kind
- != gfc_default_integer_kind
+ != gfc_default_integer_kind
|| code->expr->symtree->n.sym->as != NULL))
gfc_error ("ASSIGN statement at %L requires a scalar "
"default INTEGER variable", &code->expr->where);
resolve_forall_iterators (code->ext.forall_iterator);
if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
- gfc_error
- ("FORALL mask clause at %L requires a LOGICAL expression",
- &code->expr->where);
+ gfc_error ("FORALL mask clause at %L requires a LOGICAL "
+ "expression", &code->expr->where);
break;
case EXEC_OMP_ATOMIC:
the variable. */
static void
-resolve_values (gfc_symbol * sym)
+resolve_values (gfc_symbol *sym)
{
-
if (sym->value == NULL)
return;
/* Resolve an index expression. */
static try
-resolve_index_expr (gfc_expr * e)
+resolve_index_expr (gfc_expr *e)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
+ || !gfc_is_constant_expr (e)))
not_constant = true;
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
+ || !gfc_is_constant_expr (e)))
not_constant = true;
}
}
/* Search for the function namespace if this is a contained
function without an explicit result. */
if (sym->attr.function && sym == sym->result
- && sym->name != sym->ns->proc_name->name)
+ && sym->name != sym->ns->proc_name->name)
{
ns = ns->contained;
for (;ns; ns = ns->sibling)
else
{
if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
+ && !sym->attr.pointer && !sym->attr.dummy)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
return SUCCESS;
}
+
/* Resolve symbols with flavor variable. */
static try
int i;
gfc_expr *e;
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 "
"SAVE attribute";
specification_expr = 1;
if (!sym->attr.use_assoc
- && !sym->attr.allocatable
- && !sym->attr.pointer
- && is_non_constant_shape_array (sym))
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && 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
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program))
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program))
{
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
}
if (!gfc_is_constant_expr (e)
- && !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
- && sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
+ && !(e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc)
{
gfc_error ("'%s' at %L must have constant character length "
"in this context", sym->name, &sym->declared_at);
for (i = 0; i < sym->as->rank; i++)
{
if (sym->as->lower[i] == NULL
- || sym->as->lower[i]->expr_type != EXPR_CONSTANT
- || sym->as->upper[i] == NULL
- || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
+ || sym->as->lower[i]->expr_type != EXPR_CONSTANT
+ || sym->as->upper[i] == NULL
+ || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
flag = 1;
break;
gfc_symbol *s;
gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
if (s && (s->attr.flavor != FL_DERIVED
- || !gfc_compare_derived_types (s, sym->ts.derived)))
+ || !gfc_compare_derived_types (s, sym->ts.derived)))
{
gfc_error ("The type %s cannot be host associated at %L because "
"it is blocked by an incompatible object of the same "
constructor_expr = NULL;
if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
- constructor_expr = gfc_default_initializer (&sym->ts);
+ constructor_expr = gfc_default_initializer (&sym->ts);
if (sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && constructor_expr
- && !sym->ns->save_all && !sym->attr.save
- && !sym->attr.pointer && !sym->attr.allocatable)
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && constructor_expr
+ && !sym->ns->save_all && !sym->attr.save
+ && !sym->attr.pointer && !sym->attr.allocatable)
{
gfc_error("Object '%s' at %L must have the SAVE attribute %s",
sym->name, &sym->declared_at,
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED
- && !sym->value
- && !sym->attr.pointer
- && !sym->attr.allocatable
- && (!flag || sym->attr.intent == INTENT_OUT))
+ && !sym->value
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && (!flag || sym->attr.intent == INTENT_OUT))
sym->value = gfc_default_initializer (&sym->ts);
return SUCCESS;
"interfaces", sym->name, &sym->declared_at);
if (sym->attr.function
- && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
+ && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
{
if (sym->attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return FAILURE;
- }
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
if (sym->attr.external && sym->formal == NULL
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Automatic character length function '%s' at %L must "
- "have an explicit interface", sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Automatic character length function '%s' at %L must "
+ "have an explicit interface", sym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
}
/* Ensure that derived type for are not of a private type. Internal
externally accessible and can access all the objects accessible in
the host. */
if (!(sym->ns->parent
- && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
{
for (arg = sym->formal; arg; arg = arg->next)
{
if (arg->sym
- && arg->sym->ts.type == BT_DERIVED
- && !arg->sym->ts.derived->attr.use_assoc
- && !gfc_check_access(arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access))
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
{
gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
"a dummy argument of '%s', which is "
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl && sym->ts.cl->length == NULL)
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl && sym->ts.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
- || (sym->attr.recursive) || (sym->attr.pure))
+ || (sym->attr.recursive) || (sym->attr.pure))
{
if (sym->as && sym->as->rank)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
}
if (c->ts.type == BT_DERIVED
- && sym->component_access != ACCESS_PRIVATE
- && gfc_check_access(sym->attr.access, sym->ns->default_access)
- && !c->ts.derived->attr.use_assoc
- && !gfc_check_access(c->ts.derived->attr.access,
- c->ts.derived->ns->default_access))
+ && sym->component_access != ACCESS_PRIVATE
+ && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && !c->ts.derived->attr.use_assoc
+ && !gfc_check_access (c->ts.derived->attr.access,
+ c->ts.derived->ns->default_access))
{
gfc_error ("The component '%s' is a PRIVATE type and cannot be "
"a component of '%s', which is PUBLIC at %L",
- c->name, sym->name, &sym->declared_at);
+ c->name, sym->name, &sym->declared_at);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED && c->pointer
- && c->ts.derived->components == NULL)
+ && c->ts.derived->components == NULL)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
for (i = 0; i < c->as->rank; i++)
{
if (c->as->lower[i] == NULL
- || !gfc_is_constant_expr (c->as->lower[i])
- || (resolve_index_expr (c->as->lower[i]) == FAILURE)
- || c->as->upper[i] == NULL
- || (resolve_index_expr (c->as->upper[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->upper[i]))
+ || !gfc_is_constant_expr (c->as->lower[i])
+ || (resolve_index_expr (c->as->lower[i]) == FAILURE)
+ || c->as->upper[i] == NULL
+ || (resolve_index_expr (c->as->upper[i]) == FAILURE)
+ || !gfc_is_constant_expr (c->as->upper[i]))
{
gfc_error ("Component '%s' of '%s' at %L must have "
"constant array bounds",
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
- && !(sym->ns->parent == nl->sym->ns)
- && !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ && !(sym->ns->parent == nl->sym->ns)
+ && !gfc_check_access(nl->sym->attr.access,
+ nl->sym->ns->default_access))
{
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
for (nl = sym->namelist; nl; nl = nl->next)
{
if (nl->sym->ts.type == BT_DERIVED
- && nl->sym->ts.derived->attr.alloc_comp)
+ && nl->sym->ts.derived->attr.alloc_comp)
{
gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
"components", nl->sym->name, &sym->declared_at);
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
if (sym->attr.implicit_type
- && !gfc_compare_types (&sym->ts,
- gfc_get_default_type (sym, sym->ns)))
+ && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
{
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
type checking is deferred until resolution because the type may
refer to a derived type from the host. */
if (sym->ts.type == BT_DERIVED
- && !gfc_compare_types (&sym->ts, &sym->value->ts))
+ && !gfc_compare_types (&sym->ts, &sym->value->ts))
{
gfc_error ("Incompatible derived type in PARAMETER at %L",
&sym->value->where);
of thing commonly happens for symbols in module. */
static void
-resolve_symbol (gfc_symbol * sym)
+resolve_symbol (gfc_symbol *sym)
{
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
- /* Result may be in another namespace. */
+ /* Result may be in another namespace. */
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
until resolution time. */
if (!sym->attr.dummy
- && (sym->attr.optional
- || sym->attr.intent != INTENT_UNKNOWN))
+ && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
{
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
return;
}
-
/* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most
conditions that produce undefined derived types have already
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED
- && sym->ts.derived->components == NULL)
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
- && sym->attr.dummy
- && sym->attr.intent == INTENT_OUT
- && sym->as
- && sym->as->type == AS_ASSUMED_SIZE)
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT
+ && sym->as
+ && sym->as->type == AS_ASSUMED_SIZE)
{
for (c = sym->ts.derived->components; c; c = c->next)
{
/* Make sure that intrinsic exist */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
- && ! gfc_intrinsic_name(sym->name, 0)
- && ! gfc_intrinsic_name(sym->name, 1))
+ && !gfc_intrinsic_name(sym->name, 0)
+ && !gfc_intrinsic_name(sym->name, 1))
gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
/* Resolve array specifier. Check as well some constraints
/* Check threadprivate restrictions. */
if (sym->attr.threadprivate && !sym->attr.save
&& (!sym->attr.in_common
- && sym->module == NULL
- && (sym->ns->proc_name == NULL
- || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+ && sym->module == NULL
+ && (sym->ns->proc_name == NULL
+ || sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
/* If we have come this far we can apply default-initializers, as
described in 14.7.5, to those variables that have not already
been assigned one. */
if (sym->ts.type == BT_DERIVED
- && sym->attr.referenced
- && sym->ns == gfc_current_ns
- && !sym->value
- && !sym->attr.allocatable
- && !sym->attr.alloc_comp)
+ && sym->attr.referenced
+ && sym->ns == gfc_current_ns
+ && !sym->value
+ && !sym->attr.allocatable
+ && !sym->attr.alloc_comp)
{
symbol_attribute *a = &sym->attr;
if ((!a->save && !a->dummy && !a->pointer
- && !a->in_common && !a->use_assoc
- && !(a->function && sym != sym->result))
- ||
- (a->dummy && a->intent == INTENT_OUT))
+ && !a->in_common && !a->use_assoc
+ && !(a->function && sym != sym->result))
+ || (a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym);
}
}
-
/************* Resolve DATA statements *************/
static struct
static try
-check_data_variable (gfc_data_variable * var, locus * where)
+check_data_variable (gfc_data_variable *var, locus *where)
{
gfc_expr *e;
mpz_t size;
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->symtree->n.sym->ns->is_block_data
- && !e->symtree->n.sym->attr.in_common)
+ && !e->symtree->n.sym->attr.in_common)
{
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
- e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
+ e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
}
if (e->rank == 0)
break;
case AR_SECTION:
- ar = &ref->u.ar;
- /* Get the start position of array section. */
- gfc_get_section_index (ar, section_index, &offset);
- mark = AR_SECTION;
+ ar = &ref->u.ar;
+ /* Get the start position of array section. */
+ gfc_get_section_index (ar, section_index, &offset);
+ mark = AR_SECTION;
break;
default:
if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
- mpz_clear (section_index[i]);
+ mpz_clear (section_index[i]);
}
mpz_clear (size);
/* Iterate over a list of elements in a DATA statement. */
static try
-traverse_data_list (gfc_data_variable * var, locus * where)
+traverse_data_list (gfc_data_variable *var, locus *where)
{
mpz_t trip;
iterator_stack frame;
step = gfc_copy_expr (var->iter.step);
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",
- &start->where);
+ gfc_error ("iterator start at %L does not simplify", &start->where);
retval = FAILURE;
goto cleanup;
}
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",
- &end->where);
+ gfc_error ("iterator end at %L does not simplify", &end->where);
retval = FAILURE;
goto cleanup;
}
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",
- &step->where);
+ gfc_error ("iterator step at %L does not simplify", &step->where);
retval = FAILURE;
goto cleanup;
}
/* Type resolve variables in the variable list of a DATA statement. */
static try
-traverse_data_var (gfc_data_variable * var, locus * where)
+traverse_data_var (gfc_data_variable *var, locus *where)
{
try t;
only be resolved once. */
static try
-resolve_data_variables (gfc_data_variable * d)
+resolve_data_variables (gfc_data_variable *d)
{
for (; d; d = d->next)
{
/* 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
-gfc_impure_variable (gfc_symbol * sym)
+gfc_impure_variable (gfc_symbol *sym)
{
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
symbol of the current procedure. */
int
-gfc_pure (gfc_symbol * sym)
+gfc_pure (gfc_symbol *sym)
{
symbol_attribute attr;
/* Test whether the current procedure is elemental or not. */
int
-gfc_elemental (gfc_symbol * sym)
+gfc_elemental (gfc_symbol *sym)
{
symbol_attribute attr;
/* Warn about unused labels. */
static void
-warn_unused_fortran_label (gfc_st_label * label)
+warn_unused_fortran_label (gfc_st_label *label)
{
if (label == NULL)
return;
case BT_REAL:
if (!(ts.kind == gfc_default_real_kind
- || ts.kind == gfc_default_double_kind))
+ || ts.kind == gfc_default_double_kind))
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
if (!derived->attr.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;
}
if (derived->attr.alloc_comp)
{
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;
}
for (; c ; c = c->next)
{
d = c->ts.derived;
- if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
- return FAILURE;
+ if (d
+ && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
+ return FAILURE;
/* Shall not be an object of sequence derived type containing a pointer
- in the structure. */
+ in the structure. */
if (c->pointer)
- {
- gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
- "cannot be an EQUIVALENCE object", sym->name, &e->where);
- return FAILURE;
- }
+ {
+ gfc_error ("Derived type variable '%s' at %L with pointer "
+ "component(s) cannot be an EQUIVALENCE object",
+ sym->name, &e->where);
+ return FAILURE;
+ }
if (c->initializer)
- {
- gfc_error ("Derived type variable '%s' at %L with default initializer "
- "cannot be an EQUIVALENCE object", sym->name, &e->where);
- return FAILURE;
- }
+ {
+ gfc_error ("Derived type variable '%s' at %L with default "
+ "initializer cannot be an EQUIVALENCE object",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
}
}
if (gfc_resolve_expr (e) == FAILURE)
- continue;
+ continue;
sym = e->symtree->n.sym;
"PROTECTED attribute",
&e->where);
break;
- }
+ }
/* An equivalence statement cannot have more than one initialized
object. */
/* Shall not equivalence common block variables in a PURE procedure. */
if (sym->ns->proc_name
- && sym->ns->proc_name->attr.pure
- && sym->attr.in_common)
- {
- gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
+ && sym->ns->proc_name->attr.pure
+ && sym->attr.in_common)
+ {
+ gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
"object in the pure procedure '%s'",
sym->name, &e->where, sym->ns->proc_name->name);
- break;
- }
+ break;
+ }
/* Shall not be a named constant. */
if (e->expr_type == EXPR_CONSTANT)
- {
- gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
+ {
+ gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
+ }
derived = e->ts.derived;
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
- continue;
+ continue;
/* Check that the types correspond correctly:
Note 5.28:
msg = "Sequence %s with mixed components in EQUIVALENCE "
"statement at %L with different type objects";
if ((object ==2
- && last_eq_type == SEQ_MIXED
- && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
- last_where) == FAILURE)
- || (eq_type == SEQ_MIXED
- && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
- &e->where) == FAILURE))
+ && last_eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
+ == FAILURE)
+ || (eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
continue;
msg = "Non-default type object or sequence %s in EQUIVALENCE "
"statement at %L with objects of different type";
if ((object ==2
- && last_eq_type == SEQ_NONDEFAULT
- && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
- last_where) == FAILURE)
- || (eq_type == SEQ_NONDEFAULT
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE))
+ && last_eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
continue;
msg ="Non-CHARACTER object '%s' in default CHARACTER "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_CHARACTER
- && eq_type != SEQ_CHARACTER
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE)
+ && eq_type != SEQ_CHARACTER
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
continue;
msg ="Non-NUMERIC object '%s' in default NUMERIC "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_NUMERIC
- && eq_type != SEQ_NUMERIC
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE)
+ && eq_type != SEQ_NUMERIC
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
continue;
identical_types:
last_where = &e->where;
if (!e->ref)
- continue;
+ continue;
/* Shall not be an automatic array. */
if (e->ref->type == REF_ARRAY
- && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
- {
- gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
- "an EQUIVALENCE object", sym->name, &e->where);
- continue;
- }
+ && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
+ {
+ gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
+ "an EQUIVALENCE object", sym->name, &e->where);
+ continue;
+ }
r = e->ref;
while (r)
- {
+ {
/* Shall not be a structure component. */
if (r->type == REF_COMPONENT)
{
/* Resolve function and ENTRY types, issue diagnostics if needed. */
static void
-resolve_fntype (gfc_namespace * ns)
+resolve_fntype (gfc_namespace *ns)
{
gfc_entry_list *el;
gfc_symbol *sym;
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
&& !gfc_check_access (sym->ts.derived->attr.access,
- sym->ts.derived->ns->default_access)
+ sym->ts.derived->ns->default_access)
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{
gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
- sym->name, &sym->declared_at, sym->ts.derived->name);
+ sym->name, &sym->declared_at, sym->ts.derived->name);
}
/* Make sure that the type of a module derived type function is in the
module namespace, by copying it from the namespace's derived type
list, if necessary. */
if (sym->ts.type == BT_DERIVED
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && sym->ts.derived->ns
- && sym->ns != sym->ts.derived->ns)
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && sym->ts.derived->ns
+ && sym->ns != sym->ts.derived->ns)
{
gfc_dt_list *dt = sym->ns->derived_types;
for (; dt; dt = dt->next)
- if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
+ if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
sym->ts.derived = dt->derived;
}
/* 12.3.2.1.1 Defined operators. */
static void
-gfc_resolve_uops(gfc_symtree *symtree)
+gfc_resolve_uops (gfc_symtree *symtree)
{
gfc_interface *itr;
gfc_symbol *sym;
{
sym = itr->sym;
if (!sym->attr.function)
- gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
- sym->name, &sym->declared_at);
+ gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
+ sym->name, &sym->declared_at);
if (sym->ts.type == BT_CHARACTER
- && !(sym->ts.cl && sym->ts.cl->length)
- && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
- gfc_error("User operator procedure '%s' at %L cannot be assumed character "
- "length", sym->name, &sym->declared_at);
+ && !(sym->ts.cl && sym->ts.cl->length)
+ && !(sym->result && sym->result->ts.cl
+ && sym->result->ts.cl->length))
+ gfc_error ("User operator procedure '%s' at %L cannot be assumed "
+ "character length", sym->name, &sym->declared_at);
formal = sym->formal;
if (!formal || !formal->sym)
{
- gfc_error("User operator procedure '%s' at %L must have at least "
- "one argument", sym->name, &sym->declared_at);
+ gfc_error ("User operator procedure '%s' at %L must have at least "
+ "one argument", sym->name, &sym->declared_at);
continue;
}
block, which is handled by resolve_code. */
static void
-resolve_types (gfc_namespace * ns)
+resolve_types (gfc_namespace *ns)
{
gfc_namespace *n;
gfc_charlen *cl;
/* Call resolve_code recursively. */
static void
-resolve_codes (gfc_namespace * ns)
+resolve_codes (gfc_namespace *ns)
{
gfc_namespace *n;
which functions or subroutines. */
void
-gfc_resolve (gfc_namespace * ns)
+gfc_resolve (gfc_namespace *ns)
{
gfc_namespace *old_ns;
gfc_free(file_head);
file_head = f;
}
-
}
return open_included_file (name, intrinsic_modules_dirs, true);
}
+
/* Test to see if we're at the end of the main source file. */
int
gfc_at_end (void)
{
-
return end_flag;
}
int
gfc_at_eof (void)
{
-
if (gfc_at_end ())
return 1;
int
gfc_at_eol (void)
{
-
if (gfc_at_eof ())
return 1;
gfc_current_locus.lb = gfc_current_locus.lb->next;
- if (gfc_current_locus.lb != NULL)
+ if (gfc_current_locus.lb != NULL)
gfc_current_locus.nextc = gfc_current_locus.lb->line;
else
{
return c;
}
+
/* Skip a comment. When we come here the parse pointer is positioned
immediately after the comment character. If we ever implement
compiler directives withing comments, here is where we parse the
{
if (++continue_count == gfc_option.max_continue_free)
{
- if (gfc_notification_std (GFC_STD_GNU)
- || pedantic)
- gfc_warning ("Limit of %d continuations exceeded in statement at %C",
- gfc_option.max_continue_free);
+ if (gfc_notification_std (GFC_STD_GNU) || pedantic)
+ gfc_warning ("Limit of %d continuations exceeded in "
+ "statement at %C", gfc_option.max_continue_free);
}
}
continue_line = gfc_current_locus.lb->linenum;
if (in_string)
{
if (gfc_option.warn_ampersand)
- gfc_warning_now ("Missing '&' in continued character constant at %C");
+ gfc_warning_now ("Missing '&' in continued character "
+ "constant at %C");
gfc_current_locus.nextc--;
}
/* Both !$omp and !$ -fopenmp continuation lines have & on the
{
if (++continue_count == gfc_option.max_continue_fixed)
{
- if (gfc_notification_std (GFC_STD_GNU)
- || pedantic)
- gfc_warning ("Limit of %d continuations exceeded in statement at %C",
- gfc_option.max_continue_fixed);
+ if (gfc_notification_std (GFC_STD_GNU) || pedantic)
+ gfc_warning ("Limit of %d continuations exceeded in "
+ "statement at %C",
+ gfc_option.max_continue_fixed);
}
}
parts of gfortran. */
static int
-load_line (FILE * input, char **pbuf, int *pbuflen)
+load_line (FILE *input, char **pbuf, int *pbuflen)
{
static int linenum = 0, current_line = 1;
int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
&& !seen_printable && seen_ampersand)
{
if (pedantic)
- gfc_error_now
- ("'&' not allowed by itself in line %d", current_line);
+ gfc_error_now ("'&' not allowed by itself in line %d",
+ current_line);
else
- gfc_warning_now
- ("'&' not allowed by itself in line %d", current_line);
+ gfc_warning_now ("'&' not allowed by itself in line %d",
+ current_line);
}
break;
}
&& c == '!' && !seen_printable && seen_ampersand)
{
if (pedantic)
- gfc_error_now (
- "'&' not allowed by itself with comment in line %d", current_line);
+ gfc_error_now ("'&' not allowed by itself with comment in "
+ "line %d", current_line);
else
- gfc_warning_now (
- "'&' not allowed by itself with comment in line %d", current_line);
+ gfc_warning_now ("'&' not allowed by itself with comment in "
+ "line %d", current_line);
seen_printable = 1;
}
&& current_line != linenum)
{
linenum = current_line;
- gfc_warning_now (
- "Nonconforming tab character in column 1 of line %d", linenum);
+ gfc_warning_now ("Nonconforming tab character in column 1 "
+ "of line %d", linenum);
}
while (i <= 6)
overlong line. */
buflen = buflen * 2;
*pbuf = xrealloc (*pbuf, buflen + 1);
- buffer = (*pbuf)+i;
+ buffer = (*pbuf) + i;
}
}
else if (i >= maxlen)
/* Make filename end at quote. */
unescape = 0;
escaped = false;
- while (*c && ! (! escaped && *c == '"'))
+ while (*c && ! (!escaped && *c == '"'))
{
if (escaped)
- escaped = false;
+ escaped = false;
else if (*c == '\\')
{
escaped = true;
return true;
}
+
/* Load a file into memory by calling load_line until the file ends. */
static try
++p;
}
- if (! *p || p[1])
+ if (!*p || p[1])
return NULL;
/* Undo effects of cpp_quote_string. */
node, otherwise returns &gfc_bad_expr and frees the node. */
static gfc_expr *
-range_check (gfc_expr * result, const char *name)
+range_check (gfc_expr *result, const char *name)
{
-
switch (gfc_range_check (result))
{
case ARITH_OK:
return result;
case ARITH_OVERFLOW:
- gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
+ gfc_error ("Result of %s overflows its kind at %L", name,
+ &result->where);
break;
case ARITH_UNDERFLOW:
- gfc_error ("Result of %s underflows its kind at %L", name, &result->where);
+ gfc_error ("Result of %s underflows its kind at %L", name,
+ &result->where);
break;
case ARITH_NAN:
break;
default:
- gfc_error ("Result of %s gives range error for its kind at %L", name, &result->where);
+ gfc_error ("Result of %s gives range error for its kind at %L", name,
+ &result->where);
break;
}
kind parameter. Returns the kind, -1 if something went wrong. */
static int
-get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
+get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
If the bitsize-1 bit is set, this is taken as a sign bit and
the number is converted to the corresponding negative number. */
-
static void
convert_mpz_to_signed (mpz_t x, int bitsize)
{
mpz_sub_ui (mask, mask, 1);
/* We negate the number by hand, zeroing the high bits, that is
- make it the corresponding positive number, and then have it
- negated by GMP, giving the correct representation of the
- negative number. */
+ make it the corresponding positive number, and then have it
+ negated by GMP, giving the correct representation of the
+ negative number. */
mpz_com (x, x);
mpz_add_ui (x, x, 1);
mpz_and (x, x, mask);
/********************** Simplification functions *****************************/
gfc_expr *
-gfc_simplify_abs (gfc_expr * e)
+gfc_simplify_abs (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_achar (gfc_expr * e)
+gfc_simplify_achar (gfc_expr *e)
{
gfc_expr *result;
int index;
gfc_expr *
-gfc_simplify_acos (gfc_expr * x)
+gfc_simplify_acos (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
}
gfc_expr *
-gfc_simplify_acosh (gfc_expr * x)
+gfc_simplify_acosh (gfc_expr *x)
{
gfc_expr *result;
}
gfc_expr *
-gfc_simplify_adjustl (gfc_expr * e)
+gfc_simplify_adjustl (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
}
for (i = 0; i < len - count; ++i)
- {
- result->value.character.string[i] =
- e->value.character.string[count + i];
- }
+ result->value.character.string[i] = e->value.character.string[count + i];
for (i = len - count; i < len; ++i)
- {
- result->value.character.string[i] = ' ';
- }
+ result->value.character.string[i] = ' ';
result->value.character.string[len] = '\0'; /* For debugger */
gfc_expr *
-gfc_simplify_adjustr (gfc_expr * e)
+gfc_simplify_adjustr (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
}
for (i = 0; i < count; ++i)
- {
- result->value.character.string[i] = ' ';
- }
+ result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
- {
- result->value.character.string[i] =
- e->value.character.string[i - count];
- }
+ result->value.character.string[i] = e->value.character.string[i - count];
result->value.character.string[len] = '\0'; /* For debugger */
gfc_expr *
-gfc_simplify_aimag (gfc_expr * e)
+gfc_simplify_aimag (gfc_expr *e)
{
-
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
gfc_expr *
-gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rtrunc, *result;
int kind;
gfc_expr *
-gfc_simplify_dint (gfc_expr * e)
+gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
gfc_expr *
-gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
gfc_expr *
-gfc_simplify_and (gfc_expr * x, gfc_expr * y)
+gfc_simplify_and (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
gfc_expr *
-gfc_simplify_dnint (gfc_expr * e)
+gfc_simplify_dnint (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_asin (gfc_expr * x)
+gfc_simplify_asin (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_asin(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ASIN");
}
gfc_expr *
-gfc_simplify_asinh (gfc_expr * x)
+gfc_simplify_asinh (gfc_expr *x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_asinh(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ASINH");
}
gfc_expr *
-gfc_simplify_atan (gfc_expr * x)
+gfc_simplify_atan (gfc_expr *x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_atan(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN");
}
gfc_expr *
-gfc_simplify_atanh (gfc_expr * x)
+gfc_simplify_atanh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) >= 0 ||
- mpfr_cmp_si (x->value.real, -1) <= 0)
+ if (mpfr_cmp_si (x->value.real, 1) >= 0
+ || mpfr_cmp_si (x->value.real, -1) <= 0)
{
gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
&x->where);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_atanh(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATANH");
}
gfc_expr *
-gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
+gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
{
gfc_expr *result;
if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
- gfc_error
- ("If first argument of ATAN2 %L is zero, then the second argument "
- "must not be zero", &x->where);
+ gfc_error ("If first argument of ATAN2 %L is zero, then the "
+ "second argument must not be zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
gfc_expr *
-gfc_simplify_bit_size (gfc_expr * e)
+gfc_simplify_bit_size (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
+gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
{
int b;
gfc_expr *
-gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
+gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
gfc_expr *ceil, *result;
int kind;
ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real);
- gfc_mpfr_to_mpz(result->value.integer, ceil->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
gfc_free_expr (ceil);
gfc_expr *
-gfc_simplify_char (gfc_expr * e, gfc_expr * k)
+gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int c, kind;
/* Common subroutine for simplifying CMPLX and DCMPLX. */
static gfc_expr *
-simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
+simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
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;
gfc_expr *
-gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
+gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
{
int kind;
gfc_expr *
-gfc_simplify_conjg (gfc_expr * e)
+gfc_simplify_conjg (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_cos (gfc_expr * x)
+gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul(result->value.complex.r, xp, xq, GFC_RND_MODE);
+ mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_cosh (gfc_expr * x)
+gfc_simplify_cosh (gfc_expr *x)
{
gfc_expr *result;
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
gfc_expr *
-gfc_simplify_dble (gfc_expr * e)
+gfc_simplify_dble (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_digits (gfc_expr * x)
+gfc_simplify_digits (gfc_expr *x)
{
int i, digits;
gfc_expr *
-gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
+gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
case BT_REAL:
if (mpfr_cmp (x->value.real, y->value.real) > 0)
- mpfr_sub (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
else
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
+gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
{
gfc_expr *a1, *a2, *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result =
- gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
+ result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, gfc_default_double_kind);
gfc_expr *
-gfc_simplify_epsilon (gfc_expr * e)
+gfc_simplify_epsilon (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_exp (gfc_expr * x)
+gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
switch (x->ts.type)
{
case BT_REAL:
- mpfr_exp(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return range_check (result, "EXP");
}
-/* FIXME: MPFR should be able to do this better */
gfc_expr *
-gfc_simplify_exponent (gfc_expr * x)
+gfc_simplify_exponent (gfc_expr *x)
{
int i;
gfc_expr *result;
gfc_expr *
-gfc_simplify_float (gfc_expr * a)
+gfc_simplify_float (gfc_expr *a)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
+gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
mpfr_t floor;
gfc_expr *
-gfc_simplify_fraction (gfc_expr * x)
+gfc_simplify_fraction (gfc_expr *x)
{
gfc_expr *result;
mpfr_t absv, exp, pow2;
gfc_expr *
-gfc_simplify_huge (gfc_expr * e)
+gfc_simplify_huge (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_iachar (gfc_expr * e)
+gfc_simplify_iachar (gfc_expr *e)
{
gfc_expr *result;
int index;
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 *
-gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
gfc_expr *
-gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
{
gfc_expr *result;
int pos, len;
for (i = 0; i < bitsize; i++)
{
if (bits[i] == 0)
- {
- mpz_clrbit (result->value.integer, i);
- }
+ mpz_clrbit (result->value.integer, i);
else if (bits[i] == 1)
- {
- mpz_setbit (result->value.integer, i);
- }
+ mpz_setbit (result->value.integer, i);
else
- {
- gfc_internal_error ("IBITS: Bad bit");
- }
+ gfc_internal_error ("IBITS: Bad bit");
}
gfc_free (bits);
gfc_expr *
-gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
+gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int k, pos;
gfc_expr *
-gfc_simplify_ichar (gfc_expr * e)
+gfc_simplify_ichar (gfc_expr *e)
{
gfc_expr *result;
int index;
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 *
-gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
+gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
{
gfc_expr *result;
int back, len, lensub;
if (back == 0)
{
-
if (lensub == 0)
{
mpz_set_si (result->value.integer, 1);
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[i])
+ if (y->value.character.string[j]
+ == x->value.character.string[i])
{
index = i + 1;
goto done;
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[i])
+ if (y->value.character.string[j]
+ == x->value.character.string[i])
{
start = i;
count = 0;
for (k = 0; k < lensub; k++)
{
- if (y->value.character.string[k] ==
- x->value.character.string[k + start])
+ if (y->value.character.string[k]
+ == x->value.character.string[k + start])
count++;
}
}
else
{
-
if (lensub == 0)
{
mpz_set_si (result->value.integer, len + 1);
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[len - i])
+ if (y->value.character.string[j]
+ == x->value.character.string[len - i])
{
index = len - i + 1;
goto done;
{
for (j = 0; j < lensub; j++)
{
- if (y->value.character.string[j] ==
- x->value.character.string[len - i])
+ if (y->value.character.string[j]
+ == x->value.character.string[len - i])
{
start = len - i;
if (start <= len - lensub)
{
count = 0;
for (k = 0; k < lensub; k++)
- if (y->value.character.string[k] ==
- x->value.character.string[k + start])
+ if (y->value.character.string[k]
+ == x->value.character.string[k + start])
count++;
if (count == lensub)
gfc_expr *
-gfc_simplify_int (gfc_expr * e, gfc_expr * k)
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rpart, *rtrunc, *result;
int kind;
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;
return range_check (result, name);
}
+
gfc_expr *
-gfc_simplify_int2 (gfc_expr * e)
+gfc_simplify_int2 (gfc_expr *e)
{
return gfc_simplify_intconv (e, 2, "INT2");
}
+
gfc_expr *
-gfc_simplify_int8 (gfc_expr * e)
+gfc_simplify_int8 (gfc_expr *e)
{
return gfc_simplify_intconv (e, 8, "INT8");
}
+
gfc_expr *
-gfc_simplify_long (gfc_expr * e)
+gfc_simplify_long (gfc_expr *e)
{
return gfc_simplify_intconv (e, 4, "LONG");
}
gfc_expr *
-gfc_simplify_ifix (gfc_expr * e)
+gfc_simplify_ifix (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
gfc_expr *
-gfc_simplify_idint (gfc_expr * e)
+gfc_simplify_idint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
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 *
-gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
+gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{
gfc_expr *result;
int shift, ashift, isize, k, *bits, i;
if (ashift > isize)
{
- gfc_error
- ("Magnitude of second argument of ISHFT exceeds bit size at %L",
- &s->where);
+ gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
+ "at %L", &s->where);
return &gfc_bad_expr;
}
gfc_expr *
-gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
+gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
{
gfc_expr *result;
int shift, ashift, isize, ssize, delta, k;
if (sz != NULL)
{
if (sz->expr_type != EXPR_CONSTANT)
- return NULL;
+ return NULL;
if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
{
gfc_expr *
-gfc_simplify_kind (gfc_expr * e)
+gfc_simplify_kind (gfc_expr *e)
{
if (e->ts.type == BT_DERIVED)
static gfc_expr *
-simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
+simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
gfc_expr *
-gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim)
{
return simplify_bound (array, dim, 0);
}
gfc_expr *
-gfc_simplify_len (gfc_expr * e)
+gfc_simplify_len (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_len_trim (gfc_expr * e)
+gfc_simplify_len_trim (gfc_expr *e)
{
gfc_expr *result;
int count, len, lentrim, i;
gfc_expr *
-gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
gfc_expr *
-gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
gfc_expr *
-gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
+gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
gfc_expr *
-gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
+gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
{
-
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
gfc_expr *
-gfc_simplify_log (gfc_expr * x)
+gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xr, xi;
case BT_REAL:
if (mpfr_sgn (x->value.real) <= 0)
{
- gfc_error
- ("Argument of LOG at %L cannot be less than or equal to zero",
- &x->where);
+ gfc_error ("Argument of LOG at %L cannot be less than or equal "
+ "to zero", &x->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
- mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpfr_init (xr);
mpfr_init (xi);
- mpfr_atan2 (result->value.complex.i, x->value.complex.i, x->value.complex.r,
- GFC_RND_MODE);
+ mpfr_atan2 (result->value.complex.i, x->value.complex.i,
+ x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_log10 (gfc_expr * x)
+gfc_simplify_log10 (gfc_expr *x)
{
gfc_expr *result;
if (mpfr_sgn (x->value.real) <= 0)
{
- gfc_error
- ("Argument of LOG10 at %L cannot be less than or equal to zero",
- &x->where);
+ gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
+ "to zero", &x->where);
return &gfc_bad_expr;
}
gfc_expr *
-gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
+gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
MAX(), -1 for MIN(). */
static gfc_expr *
-simplify_min_max (gfc_expr * expr, int sign)
+simplify_min_max (gfc_expr *expr, int sign)
{
gfc_actual_arglist *arg, *last, *extremum;
gfc_intrinsic_sym * specific;
break;
case BT_REAL:
- if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) *
- sign > 0)
+ if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
+ * sign > 0)
mpfr_set (extremum->expr->value.real, arg->expr->value.real,
- GFC_RND_MODE);
+ GFC_RND_MODE);
break;
gfc_expr *
-gfc_simplify_min (gfc_expr * e)
+gfc_simplify_min (gfc_expr *e)
{
return simplify_min_max (e, -1);
}
gfc_expr *
-gfc_simplify_max (gfc_expr * e)
+gfc_simplify_max (gfc_expr *e)
{
return simplify_min_max (e, 1);
}
gfc_expr *
-gfc_simplify_maxexponent (gfc_expr * x)
+gfc_simplify_maxexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_minexponent (gfc_expr * x)
+gfc_simplify_minexponent (gfc_expr *x)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
+gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
mpfr_t quot, iquot, term;
gfc_expr *
-gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
+gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
mpfr_t quot, iquot, term;
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
/* Result is processor-dependent. This processor just opts
- to not handle it at all. */
+ to not handle it at all. */
gfc_error ("Second argument of MODULO at %L is zero", &a->where);
gfc_free_expr (result);
return &gfc_bad_expr;
/* Exists for the sole purpose of consistency with other intrinsics. */
gfc_expr *
-gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED,
- gfc_expr * fp ATTRIBUTE_UNUSED,
- gfc_expr * l ATTRIBUTE_UNUSED,
- gfc_expr * to ATTRIBUTE_UNUSED,
- gfc_expr * tp ATTRIBUTE_UNUSED)
+gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
+ gfc_expr *fp ATTRIBUTE_UNUSED,
+ gfc_expr *l ATTRIBUTE_UNUSED,
+ gfc_expr *to ATTRIBUTE_UNUSED,
+ gfc_expr *tp ATTRIBUTE_UNUSED)
{
return NULL;
}
gfc_expr *
-gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
+gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
{
gfc_expr *result;
mpfr_t tmp;
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;
}
mpfr_init (tmp);
mpfr_set_inf (tmp, sgn);
mpfr_nexttoward (result->value.real, tmp);
- mpfr_clear(tmp);
+ mpfr_clear (tmp);
return range_check (result, "NEAREST");
}
static gfc_expr *
-simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
+simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
{
gfc_expr *itrunc, *result;
int kind;
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_expr *
-gfc_simplify_new_line (gfc_expr * e)
+gfc_simplify_new_line (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
+gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
{
return simplify_nint ("NINT", e, k);
}
gfc_expr *
-gfc_simplify_idnint (gfc_expr * e)
+gfc_simplify_idnint (gfc_expr *e)
{
return simplify_nint ("IDNINT", e, NULL);
}
gfc_expr *
-gfc_simplify_not (gfc_expr * e)
+gfc_simplify_not (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_null (gfc_expr * mold)
+gfc_simplify_null (gfc_expr *mold)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_or (gfc_expr * x, gfc_expr * y)
+gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
gfc_expr *
-gfc_simplify_precision (gfc_expr * e)
+gfc_simplify_precision (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_radix (gfc_expr * e)
+gfc_simplify_radix (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_range (gfc_expr * e)
+gfc_simplify_range (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_real (gfc_expr * e, gfc_expr * k)
+gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
gfc_expr *
-gfc_simplify_realpart (gfc_expr * e)
+gfc_simplify_realpart (gfc_expr *e)
{
gfc_expr *result;
}
gfc_expr *
-gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
+gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
{
gfc_expr *result;
int i, j, len, ncopies, nlen;
for (i = 0; i < ncopies; i++)
for (j = 0; j < len; j++)
- result->value.character.string[j + i * len] =
- e->value.character.string[j];
+ result->value.character.string[j + i * len]
+ = e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
/* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr *
-gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
- gfc_expr * pad, gfc_expr * order_exp)
+gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
+ gfc_expr *pad, gfc_expr *order_exp)
{
-
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
gfc_constructor *head, *tail;
return NULL;
if (pad != NULL
- && (pad->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (pad)))
+ && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
return NULL;
if (order_exp != NULL
{
for (i = 0; i < rank; i++)
order[i] = i;
-
}
else
{
-
for (i = 0; i < rank; i++)
x[i] = 0;
e = gfc_get_array_element (order_exp, i);
if (e == NULL)
{
- gfc_error
- ("ORDER parameter of RESHAPE at %L is not the same size "
- "as SHAPE parameter", &order_exp->where);
+ gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
+ "size as SHAPE parameter", &order_exp->where);
goto bad_reshape;
}
if (npad == 0)
{
- gfc_error
- ("PAD parameter required for short SOURCE parameter at %L",
- &source->where);
+ gfc_error ("PAD parameter required for short SOURCE parameter "
+ "at %L", &source->where);
goto bad_reshape;
}
gfc_expr *
-gfc_simplify_rrspacing (gfc_expr * x)
+gfc_simplify_rrspacing (gfc_expr *x)
{
gfc_expr *result;
int i;
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
- /* Special case x = 0 and 0. */
+ /* Special case x = -0 and 0. */
if (mpfr_sgn (result->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
+gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
{
int k, neg_flag, power, exp_range;
mpfr_t scale, radix;
gfc_expr *
-gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
+gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
{
gfc_expr *result;
int back;
else
{
if (back == 0)
- {
- indx =
- strcspn (e->value.character.string, c->value.character.string) + 1;
- if (indx > len)
- indx = 0;
- }
+ {
+ indx = strcspn (e->value.character.string, c->value.character.string)
+ + 1;
+ if (indx > len)
+ indx = 0;
+ }
else
- {
- i = 0;
- for (indx = len; indx > 0; indx--)
- {
- for (i = 0; i < lenc; i++)
- {
- if (c->value.character.string[i]
- == e->value.character.string[indx - 1])
- break;
- }
- if (i < lenc)
- break;
- }
- }
+ {
+ i = 0;
+ for (indx = len; indx > 0; indx--)
+ {
+ for (i = 0; i < lenc; i++)
+ {
+ if (c->value.character.string[i]
+ == e->value.character.string[indx - 1])
+ break;
+ }
+ if (i < lenc)
+ break;
+ }
+ }
}
mpz_set_ui (result->value.integer, indx);
return range_check (result, "SCAN");
gfc_expr *
-gfc_simplify_selected_int_kind (gfc_expr * e)
+gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
gfc_expr *result;
gfc_expr *
-gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
+gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
{
int range, precision, i, kind, found_precision, found_range;
gfc_expr *result;
gfc_expr *
-gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
+gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
mpfr_t exp, absv, log2, pow2, frac;
gfc_expr *
-gfc_simplify_shape (gfc_expr * source)
+gfc_simplify_shape (gfc_expr *source)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f;
gfc_expr *
-gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
{
mpz_t size;
gfc_expr *result;
gfc_expr *
-gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
+gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
case BT_REAL:
/* TODO: Handle -0.0 and +0.0 correctly on machines that support
- it. */
+ it. */
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
if (mpfr_sgn (y->value.real) < 0)
mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_sin (gfc_expr * x)
+gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
mpfr_t xp, xq;
gfc_expr *
-gfc_simplify_sinh (gfc_expr * x)
+gfc_simplify_sinh (gfc_expr *x)
{
gfc_expr *result;
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");
}
single precision. TODO: Rounding! */
gfc_expr *
-gfc_simplify_sngl (gfc_expr * a)
+gfc_simplify_sngl (gfc_expr *a)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_spacing (gfc_expr * x)
+gfc_simplify_spacing (gfc_expr *x)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_sqrt (gfc_expr * e)
+gfc_simplify_sqrt (gfc_expr *e)
{
gfc_expr *result;
mpfr_t ac, ad, s, t, w;
case BT_COMPLEX:
/* Formula taken from Numerical Recipes to avoid over- and
- underflow. */
+ underflow. */
gfc_set_model (e->value.real);
mpfr_init (ac);
if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
&& mpfr_cmp_ui (e->value.complex.i, 0) == 0)
{
-
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
gfc_expr *
-gfc_simplify_tan (gfc_expr * x)
+gfc_simplify_tan (gfc_expr *x)
{
int i;
gfc_expr *result;
gfc_expr *
-gfc_simplify_tanh (gfc_expr * x)
+gfc_simplify_tanh (gfc_expr *x)
{
gfc_expr *result;
gfc_expr *
-gfc_simplify_tiny (gfc_expr * e)
+gfc_simplify_tiny (gfc_expr *e)
{
gfc_expr *result;
int i;
gfc_expr *
-gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
+gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
-
/* Reference mold and size to suppress warning. */
if (gfc_init_expr && (mold || size))
gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
gfc_expr *
-gfc_simplify_trim (gfc_expr * e)
+gfc_simplify_trim (gfc_expr *e)
{
gfc_expr *result;
int count, i, len, lentrim;
gfc_expr *
-gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
+gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
{
return simplify_bound (array, dim, 1);
}
gfc_expr *
-gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
+gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
{
gfc_expr *result;
int back;
return result;
}
- index =
- strspn (s->value.character.string, set->value.character.string) + 1;
+ index = strspn (s->value.character.string, set->value.character.string)
+ + 1;
if (index > len)
index = 0;
return result;
}
for (index = len; index > 0; index --)
- {
- for (i = 0; i < lenset; i++)
- {
- if (s->value.character.string[index - 1]
- == set->value.character.string[i])
- break;
- }
- if (i == lenset)
- break;
- }
+ {
+ for (i = 0; i < lenset; i++)
+ {
+ if (s->value.character.string[index - 1]
+ == set->value.character.string[i])
+ break;
+ }
+ if (i == lenset)
+ break;
+ }
}
mpz_set_ui (result->value.integer, index);
gfc_expr *
-gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
+gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
int kind;
else /* BT_LOGICAL */
{
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = (x->value.logical && ! y->value.logical)
- || (! x->value.logical && y->value.logical);
+ result->value.logical = (x->value.logical && !y->value.logical)
+ || (!x->value.logical && y->value.logical);
}
return range_check (result, "XOR");
}
-
/****************** Constant simplification *****************/
/* Master function to convert one constant to another. While this is
do_simplify(). */
gfc_expr *
-gfc_convert_constant (gfc_expr * e, bt type, int kind)
+gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
gfc_constructor *head, *c, *tail = NULL;
void
gfc_simplify_init_1 (void)
{
-
invert_table (ascii_table, xascii_table);
}
/* Build executable statement trees.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
void
gfc_clear_new_st (void)
{
-
memset (&new_st, '\0', sizeof (new_st));
new_st.op = EXEC_NOP;
}
its tail, returning a pointer to the new tail. */
gfc_code *
-gfc_append_code (gfc_code * tail, gfc_code * new)
+gfc_append_code (gfc_code *tail, gfc_code *new)
{
-
if (tail != NULL)
{
while (tail->next != NULL)
/* Free a single code structure, but not the actual structure itself. */
void
-gfc_free_statement (gfc_code * p)
+gfc_free_statement (gfc_code *p)
{
-
if (p->expr)
gfc_free_expr (p->expr);
if (p->expr2)
case EXEC_DT_END:
/* The ext.dt member is a duplicate pointer and doesn't need to
- be freed. */
+ be freed. */
break;
case EXEC_FORALL:
/* Free a code statement and all other code structures linked to it. */
void
-gfc_free_statements (gfc_code * p)
+gfc_free_statements (gfc_code *p)
{
gfc_code *q;
projects / platform / upstream / linaro-gcc.git / commitdiff