mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-18 19:51:31 +08:00
Code Issues Packages Projects Releases Wiki Activity

decl.c, [...]: Update Copyright dates.

Browse Source 
2007-01-07  Steven G. Kargl  <kargl@gcc.gnu.org>

    * decl.c, dump-parse-tree.c, error.c, data.c, expr.c, dependency.c,
    convert.c:  Update Copyright dates.  Fix whitespace.

From-SVN: r120552
This commit is contained in:
Steven G. Kargl 2007-01-07 19:39:52 +00:00
parent cd85e27a61
commit 636dff67dd
8 changed files with 640 additions and 712 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View File

@ -1,3 +1,8 @@
2007-01-07 Steven G. Kargl <kargl@gcc.gnu.org>
* decl.c, dump-parse-tree.c, error.c, data.c, expr.c, dependency.c,
convert.c: Update Copyright dates. Fix whitespace.
2007-01-07 Bernhard Fischer <aldot@gcc.gnu.org>
* data.c (gfc_assign_data_value): Fix whitespace.

8
gcc/fortran/convert.c
View File

@ -1,5 +1,6 @@
/* Language-level data type conversion for GNU C.
Copyright (C) 1987, 1988, 1991, 1998, 2002 Free Software Foundation, Inc.
Copyright (C) 1987, 1988, 1991, 1998, 2002, 2007
Free Software Foundation, Inc.
This file is part of GCC.
@ -57,9 +58,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
In expr.c: expand_expr, for operands of a MULT_EXPR.
In fold-const.c: fold.
In tree.c: get_narrower and get_unwidened. */
/* Subroutines of `convert'. */
/* Create an expression whose value is that of EXPR,
@ -104,7 +104,7 @@ convert (tree type, tree expr)
e = gfc_truthvalue_conversion (e);
/* If we have a NOP_EXPR, we must fold it here to avoid
infinite recursion between fold () and convert (). */
infinite recursion between fold () and convert (). */
if (TREE_CODE (e) == NOP_EXPR)
return fold_build1 (NOP_EXPR, type, TREE_OPERAND (e, 0));
else

225
gcc/fortran/data.c
View File

@ -1,6 +1,6 @@
/* Supporting functions for resolving DATA statement.
Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
This file is part of GCC.
@ -22,14 +22,14 @@ Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
/* Notes for DATA statement implementation:
We first assign initial value to each symbol by gfc_assign_data_value
during resolveing DATA statement. Refer to check_data_variable and
traverse_data_list in resolve.c.
The complexity exists in the handling of array section, implied do
and array of struct appeared in DATA statement.
We call gfc_conv_structure, gfc_con_array_array_initializer,
etc., to convert the initial value. Refer to trans-expr.c and
trans-array.c. */
@ -42,7 +42,7 @@ static void formalize_init_expr (gfc_expr *);
/* Calculate the array element offset. */
static void
get_array_index (gfc_array_ref * ar, mpz_t * offset)
get_array_index (gfc_array_ref *ar, mpz_t *offset)
{
gfc_expr *e;
int i;
@ -61,14 +61,15 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset)
if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
|| (gfc_is_constant_expr (ar->as->upper[i]) == 0)
|| (gfc_is_constant_expr (e) == 0))
gfc_error ("non-constant array in DATA statement %L", &ar->where);
gfc_error ("non-constant array in DATA statement %L", &ar->where);
mpz_set (tmp, e->value.integer);
mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
@ -87,39 +88,40 @@ find_con_by_offset (splay_tree spt, mpz_t offset)
gfc_constructor *con;
splay_tree_node sptn;
/* The complexity is due to needing quick access to the linked list of
constructors. Both a linked list and a splay tree are used, and both are
kept up to date if they are array elements (which is the only time that
a specific constructor has to be found). */
/* The complexity is due to needing quick access to the linked list of
constructors. Both a linked list and a splay tree are used, and both
are kept up to date if they are array elements (which is the only time
that a specific constructor has to be found). */
gcc_assert (spt != NULL);
mpz_init (tmp);
sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si(offset));
sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
if (sptn)
ret = (gfc_constructor*) sptn->value;
else
{
/* Need to check and see if we match a range, so we will pull
the next lowest index and see if the range matches. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
the next lowest index and see if the range matches. */
sptn = splay_tree_predecessor (spt,
(splay_tree_key) mpz_get_si (offset));
if (sptn)
{
con = (gfc_constructor*) sptn->value;
if (mpz_cmp_ui (con->repeat, 1) > 0)
{
mpz_init (tmp);
mpz_add (tmp, con->n.offset, con->repeat);
if (mpz_cmp (offset, tmp) < 0)
ret = con;
mpz_clear (tmp);
}
else
ret = NULL; /* The range did not match. */
}
{
con = (gfc_constructor*) sptn->value;
if (mpz_cmp_ui (con->repeat, 1) > 0)
{
mpz_init (tmp);
mpz_add (tmp, con->n.offset, con->repeat);
if (mpz_cmp (offset, tmp) < 0)
ret = con;
mpz_clear (tmp);
}
else
ret = NULL; /* The range did not match. */
}
else
ret = NULL; /* No pred, so no match. */
ret = NULL; /* No pred, so no match. */
}
return ret;
@ -134,7 +136,7 @@ find_con_by_component (gfc_component *com, gfc_constructor *con)
for (; con; con = con->next)
{
if (com == con->n.component)
return con;
return con;
}
return NULL;
}
@ -146,8 +148,8 @@ find_con_by_component (gfc_component *com, gfc_constructor *con)
according to normal assignment rules. */
static gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gfc_ref * ref, gfc_expr * rvalue)
create_character_intializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
int len;
int start;
@ -181,14 +183,14 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
{
gfc_error ("failure to simplify substring reference in DATA"
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
return NULL;
}
@ -225,12 +227,13 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts,
return init;
}
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
LVALUE already has an initialization, we extend this, otherwise we
create a new one. */
void
gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
@ -262,7 +265,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
@ -289,38 +292,40 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
else
mpz_set (offset, index);
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints,NULL,NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
splay_tree_key j;
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
sptn = splay_tree_insert (spt, (splay_tree_key) mpz_get_si(offset),
(splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
j = (splay_tree_key) mpz_get_si (offset);
sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, j);
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
break;
@ -374,16 +379,16 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether they
are from data statements or F95 style declarations. Therefore,
check which is the most recent. */
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
#ifdef USE_MAPPED_LOCATION
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
? init : rvalue;
#else
expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
init : rvalue;
expr = (init->where.lb->linenum > rvalue->where.lb->linenum)
? init : rvalue;
#endif
gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
"of '%s' at %L", symbol->name, &expr->where);
@ -400,12 +405,13 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
last_con->expr = expr;
}
/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
value in RVALUE. For the nonce, LVALUE must refer to a full array, not
an array section. */
void
gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
mpz_t index, mpz_t repeat)
{
gfc_ref *ref;
@ -471,42 +477,44 @@ gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
/* Find the same element in the existing constructor. */
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
/* Splay tree containing offset and gfc_constructor. */
spt = expr->con_by_offset;
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints,NULL,NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (spt == NULL)
{
spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
expr->con_by_offset = spt;
con = NULL;
}
else
con = find_con_by_offset (spt, offset);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
sptn = splay_tree_insert (spt, (splay_tree_key) mpz_get_si(offset),
(splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, (splay_tree_key) mpz_get_si(offset));
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
else
if (con == NULL)
{
splay_tree_key j;
/* Create a new constructor. */
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
j = (splay_tree_key) mpz_get_si (offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
/* Fix up the linked list. */
sptn = splay_tree_predecessor (spt, j);
if (sptn == NULL)
{ /* Insert at the head. */
con->next = expr->value.constructor;
expr->value.constructor = con;
}
else
{ /* Insert in the chain. */
pred = (gfc_constructor*) sptn->value;
con->next = pred->next;
pred->next = con;
}
}
else
gcc_assert (ref->next != NULL);
break;
@ -612,10 +620,9 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
if ((cmp > 0 && forwards)
|| (cmp < 0 && ! forwards))
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
{
/* Reset index to start, then loop to advance the next index. */
/* Reset index to start, then loop to advance the next index. */
if (ar->start[i])
mpz_set (section_index[i], ar->start[i]->value.integer);
else
@ -635,7 +642,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
mpz_add (*offset_ret, tmp, *offset_ret);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
@ -648,7 +655,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
order. Also insert NULL entries if necessary. */
static void
formalize_structure_cons (gfc_expr * expr)
formalize_structure_cons (gfc_expr *expr)
{
gfc_constructor *head;
gfc_constructor *tail;
@ -710,7 +717,7 @@ formalize_structure_cons (gfc_expr * expr)
elements of the constructors are in the correct order. */
static void
formalize_init_expr (gfc_expr * expr)
formalize_init_expr (gfc_expr *expr)
{
expr_t type;
gfc_constructor *c;
@ -789,7 +796,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
}
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}

524
gcc/fortran/decl.c
View File

File diff suppressed because it is too large Load Diff

102
gcc/fortran/dependency.c
View File

@ -1,5 +1,6 @@
/* Dependency analysis
Copyright (C) 2000, 2001, 2002, 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of GCC.
@ -24,7 +25,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
have different dependency checking functions for different types
if dependencies. Ideally these would probably be merged. */
#include "config.h"
#include "gfortran.h"
#include "dependency.h"
@ -52,7 +52,7 @@ gfc_dependency;
def if the value could not be determined. */
int
gfc_expr_is_one (gfc_expr * expr, int def)
gfc_expr_is_one (gfc_expr *expr, int def)
{
gcc_assert (expr != NULL);
@ -70,7 +70,7 @@ gfc_expr_is_one (gfc_expr * expr, int def)
and -2 if the relationship could not be determined. */
int
gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
{
gfc_actual_arglist *args1;
gfc_actual_arglist *args2;
@ -78,15 +78,14 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
if (e1->expr_type == EXPR_OP
&& (e1->value.op.operator == INTRINSIC_UPLUS
|| e1->value.op.operator == INTRINSIC_PARENTHESES))
|| e1->value.op.operator == INTRINSIC_PARENTHESES))
return gfc_dep_compare_expr (e1->value.op.op1, e2);
if (e2->expr_type == EXPR_OP
&& (e2->value.op.operator == INTRINSIC_UPLUS
|| e2->value.op.operator == INTRINSIC_PARENTHESES))
|| e2->value.op.operator == INTRINSIC_PARENTHESES))
return gfc_dep_compare_expr (e1, e2->value.op.op1);
if (e1->expr_type == EXPR_OP
&& e1->value.op.operator == INTRINSIC_PLUS)
if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_PLUS)
{
/* Compare X+C vs. X. */
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
@ -95,8 +94,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
return mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P+Q vs. R+S. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_PLUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
{
int l, r;
@ -129,8 +127,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X vs. X+C. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_PLUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
@ -139,8 +136,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X-C vs. X. */
if (e1->expr_type == EXPR_OP
&& e1->value.op.operator == INTRINSIC_MINUS)
if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_MINUS)
{
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
&& e1->value.op.op2->ts.type == BT_INTEGER
@ -148,8 +144,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
return -mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P-Q vs. R-S. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_MINUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
{
int l, r;
@ -169,8 +164,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
}
/* Compare X vs. X-C. */
if (e2->expr_type == EXPR_OP
&& e2->value.op.operator == INTRINSIC_MINUS)
if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
@ -218,8 +212,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
case EXPR_FUNCTION:
/* We can only compare calls to the same intrinsic function. */
if (e1->value.function.isym == 0
|| e2->value.function.isym == 0
if (e1->value.function.isym == 0 || e2->value.function.isym == 0
|| e1->value.function.isym != e2->value.function.isym)
return -2;
@ -275,7 +268,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
if the results are indeterminate. N is the dimension to compare. */
int
gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
{
gfc_expr *e1;
gfc_expr *e2;
@ -375,7 +368,7 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
whose data can be reused, otherwise return NULL. */
gfc_expr *
gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
{
if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
return NULL;
@ -439,8 +432,8 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
temporary. */
static int
gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
gfc_expr * expr)
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
gfc_expr *expr)
{
gcc_assert (var->expr_type == EXPR_VARIABLE);
gcc_assert (var->rank > 0);
@ -472,8 +465,8 @@ gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
array expression OTHER, not just variables. */
static int
gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
gfc_expr * expr)
gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
gfc_expr *expr)
{
switch (other->expr_type)
{
@ -498,8 +491,8 @@ gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
FNSYM is the function being called, or NULL if not known. */
int
gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
gfc_symbol * fnsym, gfc_actual_arglist * actual)
gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
gfc_symbol *fnsym, gfc_actual_arglist *actual)
{
gfc_formal_arglist *formal;
gfc_expr *expr;
@ -518,8 +511,7 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
continue;
/* Skip intent(in) arguments if OTHER itself is intent(in). */
if (formal
&& intent == INTENT_IN
if (formal && intent == INTENT_IN
&& formal->sym->attr.intent == INTENT_IN)
continue;
@ -550,12 +542,10 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
gfc_equiv_info *s, *fl1, *fl2;
gcc_assert (e1->expr_type == EXPR_VARIABLE
&& e2->expr_type == EXPR_VARIABLE);
&& e2->expr_type == EXPR_VARIABLE);
if (!e1->symtree->n.sym->attr.in_equivalence
|| !e2->symtree->n.sym->attr.in_equivalence
|| !e1->rank
|| !e2->rank)
|| !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
return 0;
/* Go through the equiv_lists and return 1 if the variables
@ -607,7 +597,7 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
temporary. */
int
gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
{
gfc_ref *ref;
int n;
@ -637,13 +627,10 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
return 1;
/* Symbols can only alias if they have the same type. */
if (ts1->type != BT_UNKNOWN
&& ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED
&& ts2->type != BT_DERIVED)
if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
{
if (ts1->type != ts2->type
|| ts1->kind != ts2->kind)
if (ts1->type != ts2->type || ts1->kind != ts2->kind)
return 0;
}
@ -710,7 +697,7 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
/* Determines overlapping for two array sections. */
static gfc_dependency
gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref l_ar;
gfc_expr *l_start;
@ -761,7 +748,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (!l_stride)
l_dir = 1;
else if (l_stride->expr_type == EXPR_CONSTANT
&& l_stride->ts.type == BT_INTEGER)
&& l_stride->ts.type == BT_INTEGER)
l_dir = mpz_sgn (l_stride->value.integer);
else if (l_start && l_end)
l_dir = gfc_dep_compare_expr (l_end, l_start);
@ -772,7 +759,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (!r_stride)
r_dir = 1;
else if (r_stride->expr_type == EXPR_CONSTANT
&& r_stride->ts.type == BT_INTEGER)
&& r_stride->ts.type == BT_INTEGER)
r_dir = mpz_sgn (r_stride->value.integer);
else if (r_start && r_end)
r_dir = gfc_dep_compare_expr (r_end, r_start);
@ -827,18 +814,18 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
if (l_dir == -1 && r_dir == 1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
}
/* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
if (l_dir == -1 && r_dir == 1)
return GFC_DEP_EQUAL;
return GFC_DEP_EQUAL;
}
/* Check for forward dependencies x:y vs. x+1:z. */
@ -874,7 +861,7 @@ gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
/* Determines overlapping for a single element and a section. */
static gfc_dependency
gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref *ref;
gfc_expr *elem;
@ -999,7 +986,7 @@ gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
return true, and assume a dependency. */
static bool
contains_forall_index_p (gfc_expr * expr)
contains_forall_index_p (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
@ -1074,7 +1061,7 @@ contains_forall_index_p (gfc_expr * expr)
/* Determines overlapping for two single element array references. */
static gfc_dependency
gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
{
gfc_array_ref l_ar;
gfc_array_ref r_ar;
@ -1099,8 +1086,7 @@ gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
/* However, we need to be careful when either scalar expression
contains a FORALL index, as these can potentially change value
during the scalarization/traversal of this array reference. */
if (contains_forall_index_p (r_start)
|| contains_forall_index_p (l_start))
if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
return GFC_DEP_OVERLAP;
if (i != -2)
@ -1141,8 +1127,7 @@ gfc_full_array_ref_p (gfc_ref *ref)
ref->u.ar.as->upper[i])))
return false;
/* Check the stride. */
if (ref->u.ar.stride[i]
&& !gfc_expr_is_one (ref->u.ar.stride[i], 0))
if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
return false;
}
return true;
@ -1155,13 +1140,12 @@ gfc_full_array_ref_p (gfc_ref *ref)
0 : array references are identical or not overlapping. */
int
gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
{
int n;
gfc_dependency fin_dep;
gfc_dependency this_dep;
fin_dep = GFC_DEP_ERROR;
/* Dependencies due to pointers should already have been identified.
We only need to check for overlapping array references. */
@ -1186,7 +1170,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
return 0;
case REF_ARRAY:
if (lref->u.ar.dimen != rref->u.ar.dimen)
if (lref->u.ar.dimen != rref->u.ar.dimen)
{
if (lref->u.ar.type == AR_FULL)
fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL
@ -1195,7 +1179,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
: GFC_DEP_OVERLAP;
else
return 1;
return 1;
break;
}

110
gcc/fortran/dump-parse-tree.c
View File

@ -1,5 +1,6 @@
/* Parse tree dumper
Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Copyright (C) 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Steven Bosscher
This file is part of GCC.
@ -40,7 +41,7 @@ static int show_level = 0;
/* Do indentation for a specific level. */
static inline void
code_indent (int level, gfc_st_label * label)
code_indent (int level, gfc_st_label *label)
{
int i;
@ -68,9 +69,8 @@ show_indent (void)
/* Show type-specific information. */
void
gfc_show_typespec (gfc_typespec * ts)
gfc_show_typespec (gfc_typespec *ts)
{
gfc_status ("(%s ", gfc_basic_typename (ts->type));
switch (ts->type)
@ -95,9 +95,8 @@ gfc_show_typespec (gfc_typespec * ts)
/* Show an actual argument list. */
void
gfc_show_actual_arglist (gfc_actual_arglist * a)
gfc_show_actual_arglist (gfc_actual_arglist *a)
{
gfc_status ("(");
for (; a; a = a->next)
@ -122,7 +121,7 @@ gfc_show_actual_arglist (gfc_actual_arglist * a)
/* Show a gfc_array_spec array specification structure. */
void
gfc_show_array_spec (gfc_array_spec * as)
gfc_show_array_spec (gfc_array_spec *as)
{
const char *c;
int i;
@ -144,8 +143,8 @@ gfc_show_array_spec (gfc_array_spec * as)
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
default:
gfc_internal_error
("gfc_show_array_spec(): Unhandled array shape type.");
gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
"type.");
}
gfc_status (" %s ", c);
@ -233,9 +232,8 @@ gfc_show_array_ref (gfc_array_ref * ar)
/* Show a list of gfc_ref structures. */
void
gfc_show_ref (gfc_ref * p)
gfc_show_ref (gfc_ref *p)
{
for (; p; p = p->next)
switch (p->type)
{
@ -264,9 +262,8 @@ gfc_show_ref (gfc_ref * p)
/* Display a constructor. Works recursively for array constructors. */
void
gfc_show_constructor (gfc_constructor * c)
gfc_show_constructor (gfc_constructor *c)
{
for (; c; c = c->next)
{
if (c->iterator == NULL)
@ -297,7 +294,7 @@ gfc_show_constructor (gfc_constructor * c)
/* Show an expression. */
void
gfc_show_expr (gfc_expr * p)
gfc_show_expr (gfc_expr *p)
{
const char *c;
int i;
@ -530,7 +527,7 @@ gfc_show_expr (gfc_expr * p)
whatever single bit attributes are present. */
void
gfc_show_attr (symbol_attribute * attr)
gfc_show_attr (symbol_attribute *attr)
{
gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
@ -601,7 +598,7 @@ gfc_show_attr (symbol_attribute * attr)
/* Show components of a derived type. */
void
gfc_show_components (gfc_symbol * sym)
gfc_show_components (gfc_symbol *sym)
{
gfc_component *c;
@ -628,7 +625,7 @@ gfc_show_components (gfc_symbol * sym)
that symbol. */
void
gfc_show_symbol (gfc_symbol * sym)
gfc_show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
@ -683,12 +680,12 @@ gfc_show_symbol (gfc_symbol * sym)
gfc_status ("Formal arglist:");
for (formal = sym->formal; formal; formal = formal->next)
{
if (formal->sym != NULL)
gfc_status (" %s", formal->sym->name);
else
gfc_status (" [Alt Return]");
}
{
if (formal->sym != NULL)
gfc_status (" %s", formal->sym->name);
else
gfc_status (" [Alt Return]");
}
}
if (sym->formal_ns)
@ -706,7 +703,7 @@ gfc_show_symbol (gfc_symbol * sym)
and the name of the associated subroutine, really. */
static void
show_uop (gfc_user_op * uop)
show_uop (gfc_user_op *uop)
{
gfc_interface *intr;
@ -721,9 +718,8 @@ show_uop (gfc_user_op * uop)
/* Workhorse function for traversing the user operator symtree. */
static void
traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
{
if (st == NULL)
return;
@ -737,9 +733,8 @@ traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
/* Traverse the tree of user operator nodes. */
void
gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
{
traverse_uop (ns->uop_root, func);
}
@ -747,7 +742,7 @@ gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
/* Function to display a common block. */
static void
show_common (gfc_symtree * st)
show_common (gfc_symtree *st)
{
gfc_symbol *s;
@ -769,9 +764,8 @@ show_common (gfc_symtree * st)
/* Worker function to display the symbol tree. */
static void
show_symtree (gfc_symtree * st)
show_symtree (gfc_symtree *st)
{
show_indent ();
gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
@ -786,15 +780,14 @@ show_symtree (gfc_symtree * st)
static void gfc_show_code_node (int level, gfc_code * c);
static void gfc_show_code_node (int, gfc_code *);
/* Show a list of code structures. Mutually recursive with
gfc_show_code_node(). */
void
gfc_show_code (int level, gfc_code * c)
gfc_show_code (int level, gfc_code *c)
{
for (; c; c = c->next)
gfc_show_code_node (level, c);
}
@ -811,7 +804,7 @@ gfc_show_namelist (gfc_namelist *n)
if necessary. */
static void
gfc_show_omp_node (int level, gfc_code * c)
gfc_show_omp_node (int level, gfc_code *c)
{
gfc_omp_clauses *omp_clauses = NULL;
const char *name = NULL;
@ -996,10 +989,11 @@ gfc_show_omp_node (int level, gfc_code * c)
gfc_status (" (%s)", c->ext.omp_name);
}
/* Show a single code node and everything underneath it if necessary. */
static void
gfc_show_code_node (int level, gfc_code * c)
gfc_show_code_node (int level, gfc_code *c)
{
gfc_forall_iterator *fa;
gfc_open *open;
@ -1051,24 +1045,24 @@ gfc_show_code_node (int level, gfc_code * c)
case EXEC_GOTO:
gfc_status ("GOTO ");
if (c->label)
gfc_status ("%d", c->label->value);
gfc_status ("%d", c->label->value);
else
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
break;
case EXEC_CALL:
@ -1092,9 +1086,9 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("PAUSE ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
gfc_status ("%d", c->ext.stop_code);
break;
@ -1102,9 +1096,9 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("STOP ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
gfc_status ("%d", c->ext.stop_code);
break;
@ -1709,7 +1703,7 @@ gfc_show_equiv (gfc_equiv *eq)
/* Show a freakin' whole namespace. */
void
gfc_show_namespace (gfc_namespace * ns)
gfc_show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;

37
gcc/fortran/error.c
View File

@ -1,6 +1,6 @@
/* Handle errors.
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 & Niels Kristian Bech Jensen
This file is part of GCC.
@ -69,12 +69,10 @@ error_char (char c)
{
if (cur_error_buffer->index >= cur_error_buffer->allocated)
{
cur_error_buffer->allocated =
cur_error_buffer->allocated
? cur_error_buffer->allocated * 2 : 1000;
cur_error_buffer->message
= xrealloc (cur_error_buffer->message,
cur_error_buffer->allocated);
cur_error_buffer->allocated = cur_error_buffer->allocated
? cur_error_buffer->allocated * 2 : 1000;
cur_error_buffer->message = xrealloc (cur_error_buffer->message,
cur_error_buffer->allocated);
}
cur_error_buffer->message[cur_error_buffer->index++] = c;
}
@ -152,7 +150,7 @@ error_integer (int i)
static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
static void
show_locus (locus * loc, int c1, int c2)
show_locus (locus *loc, int c1, int c2)
{
gfc_linebuf *lb;
gfc_file *f;
@ -308,7 +306,7 @@ show_locus (locus * loc, int c1, int c2)
loci may or may not be on the same source line. */
static void
show_loci (locus * l1, locus * l2)
show_loci (locus *l1, locus *l2)
{
int m, c1, c2;
@ -349,7 +347,6 @@ show_loci (locus * l1, locus * l2)
show_locus (l1, c1, c2);
return;
}
@ -545,10 +542,10 @@ error_print (const char *type, const char *format0, va_list argp)
}
format++;
if (ISDIGIT(*format))
if (ISDIGIT (*format))
{
/* This is a position specifier. See comment above. */
while (ISDIGIT(*format))
while (ISDIGIT (*format))
format++;
/* Skip over the dollar sign. */
@ -663,17 +660,15 @@ gfc_notify_std (int std, const char *nocmsgid, ...)
va_list argp;
bool warning;
warning = ((gfc_option.warn_std & std) != 0)
&& !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0
&& !warning)
warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0 && !warning)
return SUCCESS;
if (gfc_suppress_error)
return warning ? SUCCESS : FAILURE;
cur_error_buffer = (warning && !warnings_are_errors)
? &warning_buffer : &error_buffer;
? &warning_buffer : &error_buffer;
cur_error_buffer->flag = 1;
cur_error_buffer->index = 0;
@ -889,7 +884,7 @@ gfc_error_check (void)
/* Save the existing error state. */
void
gfc_push_error (gfc_error_buf * err)
gfc_push_error (gfc_error_buf *err)
{
err->flag = error_buffer.flag;
if (error_buffer.flag)
@ -902,7 +897,7 @@ gfc_push_error (gfc_error_buf * err)
/* Restore a previous pushed error state. */
void
gfc_pop_error (gfc_error_buf * err)
gfc_pop_error (gfc_error_buf *err)
{
error_buffer.flag = err->flag;
if (error_buffer.flag)
@ -918,7 +913,7 @@ gfc_pop_error (gfc_error_buf * err)
/* Free a pushed error state, but keep the current error state. */
void
gfc_free_error (gfc_error_buf * err)
gfc_free_error (gfc_error_buf *err)
{
if (err->flag)
gfc_free (err->message);

341
gcc/fortran/expr.c
View File

@ -1,6 +1,6 @@
/* Routines for manipulation of expression nodes.
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.
@ -34,7 +34,6 @@ gfc_get_expr (void)
gfc_expr *e;
e = gfc_getmem (sizeof (gfc_expr));
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
@ -47,7 +46,7 @@ gfc_get_expr (void)
/* Free an argument list and everything below it. */
void
gfc_free_actual_arglist (gfc_actual_arglist * a1)
gfc_free_actual_arglist (gfc_actual_arglist *a1)
{
gfc_actual_arglist *a2;
@ -64,7 +63,7 @@ gfc_free_actual_arglist (gfc_actual_arglist * a1)
/* Copy an arglist structure and all of the arguments. */
gfc_actual_arglist *
gfc_copy_actual_arglist (gfc_actual_arglist * p)
gfc_copy_actual_arglist (gfc_actual_arglist *p)
{
gfc_actual_arglist *head, *tail, *new;
@ -93,7 +92,7 @@ gfc_copy_actual_arglist (gfc_actual_arglist * p)
/* Free a list of reference structures. */
void
gfc_free_ref_list (gfc_ref * p)
gfc_free_ref_list (gfc_ref *p)
{
gfc_ref *q;
int i;
@ -134,7 +133,7 @@ gfc_free_ref_list (gfc_ref * p)
something else or the expression node belongs to another structure. */
static void
free_expr0 (gfc_expr * e)
free_expr0 (gfc_expr *e)
{
int n;
@ -221,9 +220,8 @@ free_expr0 (gfc_expr * e)
/* Free an expression node and everything beneath it. */
void
gfc_free_expr (gfc_expr * e)
gfc_free_expr (gfc_expr *e)
{
if (e == NULL)
return;
if (e->con_by_offset)
@ -236,12 +234,10 @@ gfc_free_expr (gfc_expr * e)
/* Graft the *src expression onto the *dest subexpression. */
void
gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
{
free_expr0 (dest);
*dest = *src;
gfc_free (src);
}
@ -252,9 +248,8 @@ gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
failure is OK for some callers. */
const char *
gfc_extract_int (gfc_expr * expr, int *result)
gfc_extract_int (gfc_expr *expr, int *result)
{
if (expr->expr_type != EXPR_CONSTANT)
return _("Constant expression required at %C");
@ -276,7 +271,7 @@ gfc_extract_int (gfc_expr * expr, int *result)
/* Recursively copy a list of reference structures. */
static gfc_ref *
copy_ref (gfc_ref * src)
copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
@ -312,13 +307,12 @@ copy_ref (gfc_ref * src)
}
/* Detect whether an expression has any vector index array
references. */
/* Detect whether an expression has any vector index array references. */
int
gfc_has_vector_index (gfc_expr *e)
{
gfc_ref * ref;
gfc_ref *ref;
int i;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
@ -332,7 +326,7 @@ gfc_has_vector_index (gfc_expr *e)
/* Copy a shape array. */
mpz_t *
gfc_copy_shape (mpz_t * shape, int rank)
gfc_copy_shape (mpz_t *shape, int rank)
{
mpz_t *new_shape;
int n;
@ -363,7 +357,7 @@ gfc_copy_shape (mpz_t * shape, int rank)
*/
mpz_t *
gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
{
mpz_t *new_shape, *s;
int i, n;
@ -380,12 +374,12 @@ gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
if (n < 0 || n >= rank)
return NULL;
s = new_shape = gfc_get_shape (rank-1);
s = new_shape = gfc_get_shape (rank - 1);
for (i = 0; i < rank; i++)
{
if (i == n)
continue;
continue;
mpz_init_set (*s, shape[i]);
s++;
}
@ -393,11 +387,12 @@ gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
return new_shape;
}
/* Given an expression pointer, return a copy of the expression. This
subroutine is recursive. */
gfc_expr *
gfc_copy_expr (gfc_expr * p)
gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
char *s;
@ -423,8 +418,7 @@ gfc_copy_expr (gfc_expr * p)
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string,
p->value.character.length + 1);
memcpy (s, p->value.character.string, p->value.character.length + 1);
break;
}
switch (q->ts.type)
@ -434,15 +428,15 @@ gfc_copy_expr (gfc_expr * p)
break;
case BT_REAL:
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.real);
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.real);
mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
gfc_set_model_kind (q->ts.kind);
mpfr_init (q->value.complex.r);
mpfr_init (q->value.complex.i);
mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
break;
@ -452,8 +446,7 @@ gfc_copy_expr (gfc_expr * p)
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string,
p->value.character.length + 1);
memcpy (s, p->value.character.string, p->value.character.length + 1);
break;
case BT_LOGICAL:
@ -512,9 +505,8 @@ gfc_copy_expr (gfc_expr * p)
kind numbers mean more precision for numeric types. */
int
gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
{
return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}
@ -524,7 +516,6 @@ gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
static int
numeric_type (bt type)
{
return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}
@ -532,9 +523,8 @@ numeric_type (bt type)
/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
int
gfc_numeric_ts (gfc_typespec * ts)
gfc_numeric_ts (gfc_typespec *ts)
{
return numeric_type (ts->type);
}
@ -562,7 +552,7 @@ gfc_int_expr (int i)
/* Returns an expression node that is a logical constant. */
gfc_expr *
gfc_logical_expr (int i, locus * where)
gfc_logical_expr (int i, locus *where)
{
gfc_expr *p;
@ -586,7 +576,7 @@ gfc_logical_expr (int i, locus * where)
argument list with a NULL pointer terminating the list. */
gfc_expr *
gfc_build_conversion (gfc_expr * e)
gfc_build_conversion (gfc_expr *e)
{
gfc_expr *p;
@ -612,7 +602,7 @@ gfc_build_conversion (gfc_expr * e)
1.0**2 stays as it is. */
void
gfc_type_convert_binary (gfc_expr * e)
gfc_type_convert_binary (gfc_expr *e)
{
gfc_expr *op1, *op2;
@ -628,10 +618,9 @@ gfc_type_convert_binary (gfc_expr * e)
/* Kind conversions of same type. */
if (op1->ts.type == op2->ts.type)
{
if (op1->ts.kind == op2->ts.kind)
{
/* No type conversions. */
/* No type conversions. */
e->ts = op1->ts;
goto done;
}
@ -685,7 +674,7 @@ done:
function expects that the expression has already been simplified. */
int
gfc_is_constant_expr (gfc_expr * e)
gfc_is_constant_expr (gfc_expr *e)
{
gfc_constructor *c;
gfc_actual_arglist *arg;
@ -757,7 +746,7 @@ gfc_is_constant_expr (gfc_expr * e)
/* Try to collapse intrinsic expressions. */
static try
simplify_intrinsic_op (gfc_expr * p, int type)
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_expr *op1, *op2, *result;
@ -882,9 +871,8 @@ simplify_intrinsic_op (gfc_expr * p, int type)
with gfc_simplify_expr(). */
static try
simplify_constructor (gfc_constructor * c, int type)
simplify_constructor (gfc_constructor *c, int type)
{
for (; c; c = c->next)
{
if (c->iterator
@ -904,8 +892,8 @@ simplify_constructor (gfc_constructor * c, int type)
/* Pull a single array element out of an array constructor. */
static try
find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
gfc_constructor ** rval)
find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
gfc_constructor **rval)
{
unsigned long nelemen;
int i;
@ -930,10 +918,9 @@ find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
/* Check the bounds. */
if (ar->as->upper[i]
&& (mpz_cmp (e->value.integer,
ar->as->upper[i]->value.integer) > 0
|| mpz_cmp (e->value.integer,
ar->as->lower[i]->value.integer) < 0))
&& (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
|| mpz_cmp (e->value.integer,
ar->as->lower[i]->value.integer) < 0))
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
@ -942,8 +929,7 @@ find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
goto depart;
}
mpz_sub (delta, e->value.integer,
ar->as->lower[i]->value.integer);
mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
mpz_add (offset, offset, delta);
}
@ -973,7 +959,7 @@ depart:
/* Find a component of a structure constructor. */
static gfc_constructor *
find_component_ref (gfc_constructor * cons, gfc_ref * ref)
find_component_ref (gfc_constructor *cons, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
@ -994,7 +980,7 @@ find_component_ref (gfc_constructor * cons, gfc_ref * ref)
the subobject reference in the process. */
static void
remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
{
gfc_expr *e;
@ -1075,11 +1061,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
upper = ref->u.ar.as->upper[d];
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
gcc_assert(begin);
gcc_assert(begin->expr_type == EXPR_ARRAY);
gcc_assert(begin->rank == 1);
gcc_assert(begin->shape);
{
gcc_assert (begin);
gcc_assert (begin->expr_type == EXPR_ARRAY);
gcc_assert (begin->rank == 1);
gcc_assert (begin->shape);
vecsub[d] = begin->value.constructor;
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
@ -1090,7 +1076,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (c = vecsub[d]; c; c = c->next)
{
if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
|| mpz_cmp (c->expr->value.integer, lower->value.integer) < 0)
|| mpz_cmp (c->expr->value.integer,
lower->value.integer) < 0)
{
gfc_error ("index in dimension %d is out of bounds "
"at %L", d + 1, &ref->u.ar.c_where[d]);
@ -1098,12 +1085,12 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
goto cleanup;
}
}
}
}
else
{
{
if ((begin && begin->expr_type != EXPR_CONSTANT)
|| (finish && finish->expr_type != EXPR_CONSTANT)
|| (step && step->expr_type != EXPR_CONSTANT))
|| (finish && finish->expr_type != EXPR_CONSTANT)
|| (step && step->expr_type != EXPR_CONSTANT))
{
t = FAILURE;
goto cleanup;
@ -1157,8 +1144,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
mpz_div (tmp_mpz, tmp_mpz, stride[d]);
mpz_mul (nelts, nelts, tmp_mpz);
/* An element reference reduces the rank of the expression; don't add
anything to the shape array. */
/* An element reference reduces the rank of the expression; don't
add anything to the shape array. */
if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
mpz_set (expr->shape[shape_i++], tmp_mpz);
}
@ -1178,7 +1165,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
/* Now clock through the array reference, calculating the index in
the source constructor and transferring the elements to the new
constructor. */
for (idx = 0; idx < (int)mpz_get_si (nelts); idx++)
for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
{
if (ref->u.ar.offset)
mpz_set (ptr, ref->u.ar.offset->value.integer);
@ -1189,14 +1176,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (d = 0; d < rank; d++)
{
mpz_set (tmp_mpz, ctr[d]);
mpz_sub (tmp_mpz, tmp_mpz,
ref->u.ar.as->lower[d]->value.integer);
mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
mpz_add (ptr, ptr, tmp_mpz);
if (!incr_ctr) continue;
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
gcc_assert(vecsub[d]);
@ -1213,9 +1199,9 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
{
mpz_add (ctr[d], ctr[d], stride[d]);
if (mpz_cmp_ui (stride[d], 0) > 0 ?
mpz_cmp (ctr[d], end[d]) > 0 :
mpz_cmp (ctr[d], end[d]) < 0)
if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0
: mpz_cmp (ctr[d], end[d]) < 0)
mpz_set (ctr[d], start[d]);
else
incr_ctr = false;
@ -1269,13 +1255,13 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
char *chr;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
return FAILURE;
*newp = gfc_copy_expr (p);
chr = p->value.character.string;
end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer);
start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer);
end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
(*newp)->value.character.length = end - start + 1;
strncpy ((*newp)->value.character.string, &chr[start - 1],
@ -1289,7 +1275,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
parameter variable values are substituted. */
static try
simplify_const_ref (gfc_expr * p)
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons;
gfc_expr *newp;
@ -1302,8 +1288,7 @@ simplify_const_ref (gfc_expr * p)
switch (p->ref->u.ar.type)
{
case AR_ELEMENT:
if (find_array_element (p->value.constructor,
&p->ref->u.ar,
if (find_array_element (p->value.constructor, &p->ref->u.ar,
&cons) == FAILURE)
return FAILURE;
@ -1322,7 +1307,7 @@ simplify_const_ref (gfc_expr * p)
case AR_FULL:
if (p->ref->next != NULL
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
cons = p->value.constructor;
for (; cons; cons = cons->next)
@ -1364,7 +1349,7 @@ simplify_const_ref (gfc_expr * p)
/* Simplify a chain of references. */
static try
simplify_ref_chain (gfc_ref * ref, int type)
simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
@ -1375,16 +1360,12 @@ simplify_ref_chain (gfc_ref * ref, int type)
case REF_ARRAY:
for (n = 0; n < ref->u.ar.dimen; n++)
{
if (gfc_simplify_expr (ref->u.ar.start[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (ref->u.ar.end[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (ref->u.ar.stride[n], type)
== FAILURE)
if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
return FAILURE;
}
break;
@ -1405,7 +1386,7 @@ simplify_ref_chain (gfc_ref * ref, int type)
/* Try to substitute the value of a parameter variable. */
static try
simplify_parameter_variable (gfc_expr * p, int type)
simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
try t;
@ -1423,7 +1404,7 @@ simplify_parameter_variable (gfc_expr * p, int type)
/* Only use the simplification if it eliminated all subobject
references. */
if (t == SUCCESS && ! e->ref)
if (t == SUCCESS && !e->ref)
gfc_replace_expr (p, e);
else
gfc_free_expr (e);
@ -1446,12 +1427,12 @@ simplify_parameter_variable (gfc_expr * p, int type)
The expression type is defined for:
0 Basic expression parsing
1 Simplifying array constructors -- will substitute
iterator values.
iterator values.
Returns FAILURE on error, SUCCESS otherwise.
NOTE: Will return SUCCESS even if the expression can not be simplified. */
try
gfc_simplify_expr (gfc_expr * p, int type)
gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
@ -1489,7 +1470,7 @@ gfc_simplify_expr (gfc_expr * p, int type)
gfc_extract_int (p->ref->u.ss.end, &end);
s = gfc_getmem (end - start + 2);
memcpy (s, p->value.character.string + start, end - start);
s[end-start+1] = '\0'; /* TODO: C-style string for debugging. */
s[end - start + 1] = '\0'; /* TODO: C-style string. */
gfc_free (p->value.character.string);
p->value.character.string = s;
p->value.character.length = end - start;
@ -1510,7 +1491,7 @@ gfc_simplify_expr (gfc_expr * p, int type)
case EXPR_VARIABLE:
/* Only substitute array parameter variables if we are in an
initialization expression, or we want a subsection. */
initialization expression, or we want a subsection. */
if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
&& (gfc_init_expr || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
@ -1539,9 +1520,8 @@ gfc_simplify_expr (gfc_expr * p, int type)
if (simplify_constructor (p->value.constructor, type) == FAILURE)
return FAILURE;
if (p->expr_type == EXPR_ARRAY
&& p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
gfc_expand_constructor (p);
if (simplify_const_ref (p) == FAILURE)
@ -1559,9 +1539,8 @@ gfc_simplify_expr (gfc_expr * p, int type)
be declared as. */
static bt
et0 (gfc_expr * e)
et0 (gfc_expr *e)
{
if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
return BT_INTEGER;
@ -1575,7 +1554,7 @@ et0 (gfc_expr * e)
static try check_init_expr (gfc_expr *);
static try
check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
@ -1605,7 +1584,7 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
{
gfc_error ("Numeric or CHARACTER operands are required in "
"expression at %L", &e->where);
return FAILURE;
return FAILURE;
}
break;
@ -1703,7 +1682,7 @@ not_numeric:
this problem here. */
static try
check_inquiry (gfc_expr * e, int not_restricted)
check_inquiry (gfc_expr *e, int not_restricted)
{
const char *name;
@ -1743,7 +1722,7 @@ check_inquiry (gfc_expr * e, int not_restricted)
{
if (e->symtree->n.sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
== FAILURE)
== FAILURE)
return FAILURE;
e->ts = e->symtree->n.sym->ts;
@ -1752,8 +1731,8 @@ check_inquiry (gfc_expr * e, int not_restricted)
/* Assumed character length will not reduce to a constant expression
with LEN, as required by the standard. */
if (i == 4 && not_restricted
&& e->symtree->n.sym->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.cl->length == NULL)
&& e->symtree->n.sym->ts.type == BT_CHARACTER
&& e->symtree->n.sym->ts.cl->length == NULL)
gfc_notify_std (GFC_STD_GNU, "assumed character length "
"variable '%s' in constant expression at %L",
e->symtree->n.sym->name, &e->where);
@ -1770,7 +1749,7 @@ check_inquiry (gfc_expr * e, int not_restricted)
FAILURE is returned an error message has been generated. */
static try
check_init_expr (gfc_expr * e)
check_init_expr (gfc_expr *e)
{
gfc_actual_arglist *ap;
match m;
@ -1809,7 +1788,7 @@ check_init_expr (gfc_expr * e)
if (m == MATCH_NO)
gfc_error ("Function '%s' in initialization expression at %L "
"must be an intrinsic function",
e->symtree->n.sym->name, &e->where);
e->symtree->n.sym->name, &e->where);
if (m != MATCH_YES)
t = FAILURE;
@ -1882,7 +1861,7 @@ check_init_expr (gfc_expr * e)
expression, then reducing it to a constant. */
match
gfc_match_init_expr (gfc_expr ** result)
gfc_match_init_expr (gfc_expr **result)
{
gfc_expr *expr;
match m;
@ -1914,9 +1893,8 @@ gfc_match_init_expr (gfc_expr ** result)
/* Not all inquiry functions are simplified to constant expressions
so it is necessary to call check_inquiry again. */
if (!gfc_is_constant_expr (expr)
&& check_inquiry (expr, 1) == FAILURE
&& !gfc_in_match_data ())
if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) == FAILURE
&& !gfc_in_match_data ())
{
gfc_error ("Initialization expression didn't reduce %C");
return MATCH_ERROR;
@ -1928,7 +1906,6 @@ gfc_match_init_expr (gfc_expr ** result)
}
static try check_restricted (gfc_expr *);
/* Given an actual argument list, test to see that each argument is a
@ -1936,7 +1913,7 @@ static try check_restricted (gfc_expr *);
integer or character. */
static try
restricted_args (gfc_actual_arglist * a)
restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
{
@ -1954,7 +1931,7 @@ restricted_args (gfc_actual_arglist * a)
/* Make sure a non-intrinsic function is a specification function. */
static try
external_spec_function (gfc_expr * e)
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
@ -1996,7 +1973,7 @@ external_spec_function (gfc_expr * e)
restricted expression. */
static try
restricted_intrinsic (gfc_expr * e)
restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
if (check_inquiry (e, 0) == SUCCESS)
@ -2011,7 +1988,7 @@ restricted_intrinsic (gfc_expr * e)
return FAILURE. */
static try
check_restricted (gfc_expr * e)
check_restricted (gfc_expr *e)
{
gfc_symbol *sym;
try t;
@ -2029,8 +2006,8 @@ check_restricted (gfc_expr * e)
break;
case EXPR_FUNCTION:
t = e->value.function.esym ?
external_spec_function (e) : restricted_intrinsic (e);
t = e->value.function.esym ? external_spec_function (e)
: restricted_intrinsic (e);
break;
@ -2052,10 +2029,11 @@ check_restricted (gfc_expr * e)
break;
}
/* gfc_is_formal_arg broadcasts that a formal argument list is being processed
in resolve.c(resolve_formal_arglist). This is done so that host associated
dummy array indices are accepted (PR23446). This mechanism also does the
same for the specification expressions of array-valued functions. */
/* gfc_is_formal_arg broadcasts that a formal argument list is being
processed in resolve.c(resolve_formal_arglist). This is done so
that host associated dummy array indices are accepted (PR23446).
This mechanism also does the same for the specification expressions
of array-valued functions. */
if (sym->attr.in_common
|| sym->attr.use_assoc
|| sym->attr.dummy
@ -2109,7 +2087,7 @@ check_restricted (gfc_expr * e)
we return FAILURE, an error has been generated. */
try
gfc_specification_expr (gfc_expr * e)
gfc_specification_expr (gfc_expr *e)
{
if (e == NULL)
return SUCCESS;
@ -2138,8 +2116,7 @@ gfc_specification_expr (gfc_expr * e)
/* Given two expressions, make sure that the arrays are conformable. */
try
gfc_check_conformance (const char *optype_msgid,
gfc_expr * op1, gfc_expr * op2)
gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
@ -2189,7 +2166,7 @@ gfc_check_conformance (const char *optype_msgid,
sure that the assignment can take place. */
try
gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
gfc_ref *ref;
@ -2219,10 +2196,9 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
function is terminated.....
Therefore, the left hand side is no longer a varaiable, when it is:*/
if (sym->attr.flavor == FL_PROCEDURE
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.external)
Therefore, the left hand side is no longer a varaiable, when it is: */
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.external)
{
bool bad_proc;
bad_proc = false;
@ -2237,10 +2213,10 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
/* (iii) A module or internal procedure.... */
if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
&& gfc_current_ns->parent
&& (!(gfc_current_ns->parent->proc_name->attr.function
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
/* .... that is not a function.... */
@ -2285,8 +2261,8 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
&& lvalue->ref->u.ar.type == AR_FULL
&& lvalue->ref->u.ar.as->cp_was_assumed)
{
gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
" is illegal", &lvalue->where);
gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
"is illegal", &lvalue->where);
return FAILURE;
}
@ -2332,7 +2308,7 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
NULLIFY statement. */
try
gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
gfc_ref *ref;
@ -2347,7 +2323,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
}
if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& lvalue->symtree->n.sym->attr.use_assoc)
&& lvalue->symtree->n.sym->attr.use_assoc)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
@ -2364,16 +2340,16 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (pointer)
check_intent_in = 0;
check_intent_in = 0;
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
pointer = 1;
pointer = 1;
}
if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
lvalue->symtree->n.sym->name, &lvalue->where);
return FAILURE;
}
@ -2387,8 +2363,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
{
gfc_error ("Bad pointer object in PURE procedure at %L",
&lvalue->where);
gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
return FAILURE;
}
@ -2415,7 +2390,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (lvalue->rank != rvalue->rank)
{
gfc_error ("Different ranks in pointer assignment at %L",
&lvalue->where);
&lvalue->where);
return FAILURE;
}
@ -2424,9 +2399,9 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
return SUCCESS;
if (lvalue->ts.type == BT_CHARACTER
&& lvalue->ts.cl->length && rvalue->ts.cl->length
&& abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
rvalue->ts.cl->length)) == 1)
&& lvalue->ts.cl->length && rvalue->ts.cl->length
&& abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
rvalue->ts.cl->length)) == 1)
{
gfc_error ("Different character lengths in pointer "
"assignment at %L", &lvalue->where);
@ -2457,7 +2432,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
if (attr.protected && attr.use_assoc)
{
gfc_error ("Pointer assigment target has PROTECTED "
"attribute at %L", &rvalue->where);
"attribute at %L", &rvalue->where);
return FAILURE;
}
@ -2469,7 +2444,7 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
symbol. Used for initialization assignments. */
try
gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
gfc_expr lvalue;
try r;
@ -2480,7 +2455,7 @@ gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
lvalue.ts = sym->ts;
if (sym->as)
lvalue.rank = sym->as->rank;
lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
@ -2510,7 +2485,7 @@ gfc_default_initializer (gfc_typespec *ts)
for (c = ts->derived->components; c; c = c->next)
{
if ((c->initializer || c->allocatable) && init == NULL)
init = gfc_get_expr ();
init = gfc_get_expr ();
}
if (init == NULL)
@ -2524,15 +2499,15 @@ gfc_default_initializer (gfc_typespec *ts)
for (c = ts->derived->components; c; c = c->next)
{
if (tail == NULL)
init->value.constructor = tail = gfc_get_constructor ();
init->value.constructor = tail = gfc_get_constructor ();
else
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
if (c->initializer)
tail->expr = gfc_copy_expr (c->initializer);
tail->expr = gfc_copy_expr (c->initializer);
if (c->allocatable)
{
@ -2550,7 +2525,7 @@ gfc_default_initializer (gfc_typespec *ts)
whole array. */
gfc_expr *
gfc_get_variable_expr (gfc_symtree * var)
gfc_get_variable_expr (gfc_symtree *var)
{
gfc_expr *e;
@ -2574,7 +2549,7 @@ gfc_get_variable_expr (gfc_symtree * var)
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
void
gfc_expr_set_symbols_referenced (gfc_expr * expr)
gfc_expr_set_symbols_referenced (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
@ -2592,7 +2567,7 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
case EXPR_FUNCTION:
for (arg = expr->value.function.actual; arg; arg = arg->next)
gfc_expr_set_symbols_referenced (arg->expr);
gfc_expr_set_symbols_referenced (arg->expr);
break;
case EXPR_VARIABLE:
@ -2607,7 +2582,7 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
case EXPR_STRUCTURE:
case EXPR_ARRAY:
for (c = expr->value.constructor; c; c = c->next)
gfc_expr_set_symbols_referenced (c->expr);
gfc_expr_set_symbols_referenced (c->expr);
break;
default:
@ -2617,26 +2592,26 @@ gfc_expr_set_symbols_referenced (gfc_expr * expr)
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
}
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
gfc_expr_set_symbols_referenced (ref->u.ss.start);
gfc_expr_set_symbols_referenced (ref->u.ss.end);
break;
default:
gcc_unreachable ();
break;
}
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
}
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
gfc_expr_set_symbols_referenced (ref->u.ss.start);
gfc_expr_set_symbols_referenced (ref->u.ss.end);
break;
default:
gcc_unreachable ();
break;
}
}