Skip to content

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

[multiple changes] 

2007-01-06  Steven G. Kargl  <kargl@gcc.gnu.org>

        * array.c, bbt.c, check.c:  Update copyright years.  Whitespace.


2006-01-06  Steven G. Kargl  <kargl@gcc.gnu.org>

        * gfortran.dg/present_1.f90:  Update error message.

From-SVN: r120542
parent ae82248d
Showing with 477 additions and 470 deletions
gcc/fortran/ChangeLog
2007-01-05 Steven G. Kargl <kargl@gcc.gnu.org>
2007-01-06 Steven G. Kargl <kargl@gcc.gnu.org>
* array.c, bbt.c, check.c: Update copyright years. Whitespace.
2007-01-06 Steven G. Kargl <kargl@gcc.gnu.org>
* arith.c: Update copyright years. Whitespace.
......
gcc/fortran/array.c
/* Array things
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.
......@@ -37,7 +37,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
/* Copy an array reference structure. */
gfc_array_ref *
gfc_copy_array_ref (gfc_array_ref * src)
gfc_copy_array_ref (gfc_array_ref *src)
{
gfc_array_ref *dest;
int i;
......@@ -69,7 +69,7 @@ gfc_copy_array_ref (gfc_array_ref * src)
expression. */
static match
match_subscript (gfc_array_ref * ar, int init)
match_subscript (gfc_array_ref *ar, int init)
{
match m;
int i;
......@@ -119,7 +119,7 @@ end_element:
if (gfc_match_char (':') == MATCH_YES)
{
m = init ? gfc_match_init_expr (&ar->stride[i])
: gfc_match_expr (&ar->stride[i]);
: gfc_match_expr (&ar->stride[i]);
if (m == MATCH_NO)
gfc_error ("Expected array subscript stride at %C");
......@@ -136,7 +136,7 @@ end_element:
to consist of init expressions. */
match
gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
{
match m;
......@@ -189,7 +189,7 @@ matched:
specifications. */
void
gfc_free_array_spec (gfc_array_spec * as)
gfc_free_array_spec (gfc_array_spec *as)
{
int i;
......@@ -210,9 +210,8 @@ gfc_free_array_spec (gfc_array_spec * as)
shape and check associated constraints. */
static try
resolve_array_bound (gfc_expr * e, int check_constant)
resolve_array_bound (gfc_expr *e, int check_constant)
{
if (e == NULL)
return SUCCESS;
......@@ -235,7 +234,7 @@ resolve_array_bound (gfc_expr * e, int check_constant)
the shape and make sure everything is integral. */
try
gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
{
gfc_expr *e;
int i;
......@@ -264,14 +263,14 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
individual specifications make sense as a whole.
Parsed Lower Upper Returned
------------------------------------
: NULL NULL AS_DEFERRED (*)
x 1 x AS_EXPLICIT
x: x NULL AS_ASSUMED_SHAPE
x:y x y AS_EXPLICIT
x:* x NULL AS_ASSUMED_SIZE
* 1 NULL AS_ASSUMED_SIZE
Parsed Lower Upper Returned
------------------------------------
: NULL NULL AS_DEFERRED (*)
x 1 x AS_EXPLICIT
x: x NULL AS_ASSUMED_SHAPE
x:y x y AS_EXPLICIT
x:* x NULL AS_ASSUMED_SIZE
* 1 NULL AS_ASSUMED_SIZE
(*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
is fixed during the resolution of formal interfaces.
......@@ -279,7 +278,7 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
Anything else AS_UNKNOWN. */
static array_type
match_array_element_spec (gfc_array_spec * as)
match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
......@@ -328,7 +327,7 @@ match_array_element_spec (gfc_array_spec * as)
it is. */
match
gfc_match_array_spec (gfc_array_spec ** asp)
gfc_match_array_spec (gfc_array_spec **asp)
{
array_type current_type;
gfc_array_spec *as;
......@@ -362,7 +361,7 @@ gfc_match_array_spec (gfc_array_spec ** asp)
}
else
switch (as->type)
{ /* See how current spec meshes with the existing */
{ /* See how current spec meshes with the existing. */
case AS_UNKNOWN:
goto cleanup;
......@@ -376,9 +375,8 @@ gfc_match_array_spec (gfc_array_spec ** asp)
if (current_type == AS_EXPLICIT)
break;
gfc_error
("Bad array specification for an explicitly shaped array"
" at %C");
gfc_error ("Bad array specification for an explicitly shaped "
"array at %C");
goto cleanup;
......@@ -387,8 +385,8 @@ gfc_match_array_spec (gfc_array_spec ** asp)
|| (current_type == AS_DEFERRED))
break;
gfc_error
("Bad array specification for assumed shape array at %C");
gfc_error ("Bad array specification for assumed shape "
"array at %C");
goto cleanup;
case AS_DEFERRED:
......@@ -452,9 +450,8 @@ cleanup:
something goes wrong. On failure, the caller must free the spec. */
try
gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
{
if (as == NULL)
return SUCCESS;
......@@ -470,7 +467,7 @@ gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
/* Copy an array specification. */
gfc_array_spec *
gfc_copy_array_spec (gfc_array_spec * src)
gfc_copy_array_spec (gfc_array_spec *src)
{
gfc_array_spec *dest;
int i;
......@@ -491,11 +488,12 @@ gfc_copy_array_spec (gfc_array_spec * src)
return dest;
}
/* Returns nonzero if the two expressions are equal. Only handles integer
constants. */
static int
compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
{
if (bound1 == NULL || bound2 == NULL
|| bound1->expr_type != EXPR_CONSTANT
......@@ -510,11 +508,12 @@ compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
return 0;
}
/* Compares two array specifications. They must be constant or deferred
shape. */
int
gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
{
int i;
......@@ -553,7 +552,7 @@ gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
elements and should be appended to by gfc_append_constructor(). */
gfc_expr *
gfc_start_constructor (bt type, int kind, locus * where)
gfc_start_constructor (bt type, int kind, locus *where)
{
gfc_expr *result;
......@@ -573,7 +572,7 @@ gfc_start_constructor (bt type, int kind, locus * where)
node onto the constructor. */
void
gfc_append_constructor (gfc_expr * base, gfc_expr * new)
gfc_append_constructor (gfc_expr *base, gfc_expr *new)
{
gfc_constructor *c;
......@@ -600,7 +599,7 @@ gfc_append_constructor (gfc_expr * base, gfc_expr * new)
constructor onto the base's one according to the offset. */
void
gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
{
gfc_constructor *c, *pre;
expr_t type;
......@@ -614,40 +613,40 @@ gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
{
c = pre = base->value.constructor;
while (c)
{
if (type == EXPR_ARRAY)
{
{
if (type == EXPR_ARRAY)
{
t = mpz_cmp (c->n.offset, c1->n.offset);
if (t < 0)
{
pre = c;
c = c->next;
}
else if (t == 0)
{
gfc_error ("duplicated initializer");
break;
}
else
break;
}
else
{
pre = c;
c = c->next;
}
}
if (t < 0)
{
pre = c;
c = c->next;
}
else if (t == 0)
{
gfc_error ("duplicated initializer");
break;
}
else
break;
}
else
{
pre = c;
c = c->next;
}
}
if (pre != c)
{
pre->next = c1;
c1->next = c;
}
{
pre->next = c1;
c1->next = c;
}
else
{
c1->next = c;
base->value.constructor = c1;
}
{
c1->next = c;
base->value.constructor = c1;
}
}
}
......@@ -672,7 +671,7 @@ gfc_get_constructor (void)
/* Free chains of gfc_constructor structures. */
void
gfc_free_constructor (gfc_constructor * p)
gfc_free_constructor (gfc_constructor *p)
{
gfc_constructor *next;
......@@ -684,7 +683,7 @@ gfc_free_constructor (gfc_constructor * p)
next = p->next;
if (p->expr)
gfc_free_expr (p->expr);
gfc_free_expr (p->expr);
if (p->iterator != NULL)
gfc_free_iterator (p->iterator, 1);
mpz_clear (p->n.offset);
......@@ -700,7 +699,7 @@ gfc_free_constructor (gfc_constructor * p)
duplicate was found. */
static int
check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
{
gfc_expr *e;
......@@ -717,9 +716,8 @@ check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
if (c->iterator->var->symtree->n.sym == master)
{
gfc_error
("DO-iterator '%s' at %L is inside iterator of the same name",
master->name, &c->where);
gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
"same name", master->name, &c->where);
return 1;
}
......@@ -735,7 +733,7 @@ static match match_array_cons_element (gfc_constructor **);
/* Match a list of array elements. */
static match
match_array_list (gfc_constructor ** result)
match_array_list (gfc_constructor **result)
{
gfc_constructor *p, *head, *tail, *new;
gfc_iterator iter;
......@@ -835,7 +833,7 @@ cleanup:
single expression or a list of elements. */
static match
match_array_cons_element (gfc_constructor ** result)
match_array_cons_element (gfc_constructor **result)
{
gfc_constructor *p;
gfc_expr *expr;
......@@ -861,7 +859,7 @@ match_array_cons_element (gfc_constructor ** result)
/* Match an array constructor. */
match
gfc_match_array_constructor (gfc_expr ** result)
gfc_match_array_constructor (gfc_expr **result)
{
gfc_constructor *head, *tail, *new;
gfc_expr *expr;
......@@ -872,14 +870,14 @@ gfc_match_array_constructor (gfc_expr ** result)
if (gfc_match (" (/") == MATCH_NO)
{
if (gfc_match (" [") == MATCH_NO)
return MATCH_NO;
return MATCH_NO;
else
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
"style array constructors at %C") == FAILURE)
return MATCH_ERROR;
end_delim = " ]";
}
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
"style array constructors at %C") == FAILURE)
return MATCH_ERROR;
end_delim = " ]";
}
}
else
end_delim = " /)";
......@@ -952,9 +950,8 @@ static enum
cons_state;
static int
check_element_type (gfc_expr * expr)
check_element_type (gfc_expr *expr)
{
if (cons_state == CONS_BAD)
return 0; /* Suppress further errors */
......@@ -986,7 +983,7 @@ check_element_type (gfc_expr * expr)
/* Recursive work function for gfc_check_constructor_type(). */
static try
check_constructor_type (gfc_constructor * c)
check_constructor_type (gfc_constructor *c)
{
gfc_expr *e;
......@@ -1014,7 +1011,7 @@ check_constructor_type (gfc_constructor * c)
On FAILURE, an error has been generated. */
try
gfc_check_constructor_type (gfc_expr * e)
gfc_check_constructor_type (gfc_expr *e)
{
try t;
......@@ -1039,15 +1036,14 @@ cons_stack;
static cons_stack *base;
static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));
static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
/* Check an EXPR_VARIABLE expression in a constructor to make sure
that that variable is an iteration variables. */
try
gfc_check_iter_variable (gfc_expr * expr)
gfc_check_iter_variable (gfc_expr *expr)
{
gfc_symbol *sym;
cons_stack *c;
......@@ -1066,7 +1062,7 @@ gfc_check_iter_variable (gfc_expr * expr)
constructor, giving variables with the names of iterators a pass. */
static try
check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
......@@ -1104,7 +1100,7 @@ check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
determined by the check_function. */
try
gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
{
cons_stack *base_save;
try t;
......@@ -1148,7 +1144,7 @@ static try expand_constructor (gfc_constructor *);
constructor. */
static try
count_elements (gfc_expr * e)
count_elements (gfc_expr *e)
{
mpz_t result;
......@@ -1175,7 +1171,7 @@ count_elements (gfc_expr * e)
constructor, freeing the rest. */
static try
extract_element (gfc_expr * e)
extract_element (gfc_expr *e)
{
if (e->rank != 0)
......@@ -1198,9 +1194,8 @@ extract_element (gfc_expr * e)
stringing new elements together. */
static try
expand (gfc_expr * e)
expand (gfc_expr *e)
{
if (current_expand.new_head == NULL)
current_expand.new_head = current_expand.new_tail =
gfc_get_constructor ();
......@@ -1224,7 +1219,7 @@ expand (gfc_expr * e)
substitute the current value of the iteration variable. */
void
gfc_simplify_iterator_var (gfc_expr * e)
gfc_simplify_iterator_var (gfc_expr *e)
{
iterator_stack *p;
......@@ -1247,9 +1242,8 @@ gfc_simplify_iterator_var (gfc_expr * e)
recursing into other constructors if present. */
static try
expand_expr (gfc_expr * e)
expand_expr (gfc_expr *e)
{
if (e->expr_type == EXPR_ARRAY)
return expand_constructor (e->value.constructor);
......@@ -1266,7 +1260,7 @@ expand_expr (gfc_expr * e)
static try
expand_iterator (gfc_constructor * c)
expand_iterator (gfc_constructor *c)
{
gfc_expr *start, *end, *step;
iterator_stack frame;
......@@ -1349,7 +1343,7 @@ cleanup:
passed expression. */
static try
expand_constructor (gfc_constructor * c)
expand_constructor (gfc_constructor *c)
{
gfc_expr *e;
......@@ -1392,7 +1386,7 @@ expand_constructor (gfc_constructor * c)
constructor if they are small enough. */
try
gfc_expand_constructor (gfc_expr * e)
gfc_expand_constructor (gfc_expr *e)
{
expand_info expand_save;
gfc_expr *f;
......@@ -1436,7 +1430,7 @@ done:
FAILURE if not so. */
static try
constant_element (gfc_expr * e)
constant_element (gfc_expr *e)
{
int rv;
......@@ -1454,7 +1448,7 @@ constant_element (gfc_expr * e)
function that traverses the expression tree. FIXME. */
int
gfc_constant_ac (gfc_expr * e)
gfc_constant_ac (gfc_expr *e)
{
expand_info expand_save;
try rc;
......@@ -1477,7 +1471,7 @@ gfc_constant_ac (gfc_expr * e)
expanded (no iterators) and zero if iterators are present. */
int
gfc_expanded_ac (gfc_expr * e)
gfc_expanded_ac (gfc_expr *e)
{
gfc_constructor *p;
......@@ -1496,7 +1490,7 @@ gfc_expanded_ac (gfc_expr * e)
be of the same type. */
static try
resolve_array_list (gfc_constructor * p)
resolve_array_list (gfc_constructor *p)
{
try t;
......@@ -1520,9 +1514,9 @@ resolve_array_list (gfc_constructor * p)
its element constructors' length. */
void
gfc_resolve_character_array_constructor (gfc_expr * expr)
gfc_resolve_character_array_constructor (gfc_expr *expr)
{
gfc_constructor * p;
gfc_constructor *p;
int max_length;
gcc_assert (expr->expr_type == EXPR_ARRAY);
......@@ -1550,32 +1544,35 @@ got_charlen:
if (expr->ts.cl->length == NULL)
{
/* Find the maximum length of the elements. Do nothing for variable array
constructor, unless the character length is constant or there is a
constant substring reference. */
/* Find the maximum length of the elements. Do nothing for variable
array constructor, unless the character length is constant or
there is a constant substring reference. */
for (p = expr->value.constructor; p; p = p->next)
{
gfc_ref *ref;
for (ref = p->expr->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
break;
if (p->expr->expr_type == EXPR_CONSTANT)
max_length = MAX (p->expr->value.character.length, max_length);
else if (ref)
max_length = MAX ((int)(mpz_get_ui (ref->u.ss.end->value.integer)
- mpz_get_ui (ref->u.ss.start->value.integer))
+ 1, max_length);
{
long j;
j = mpz_get_ui (ref->u.ss.end->value.integer)
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
max_length = MAX ((int) j, max_length);
}
else if (p->expr->ts.cl && p->expr->ts.cl->length
&& p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
max_length = MAX ((int)mpz_get_si (p->expr->ts.cl->length->value.integer),
max_length);
&& p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
{
long j;
j = mpz_get_si (p->expr->ts.cl->length->value.integer);
max_length = MAX ((int) j, max_length);
}
else
return;
}
......@@ -1592,10 +1589,11 @@ got_charlen:
}
}
/* Resolve all of the expressions in an array list. */
try
gfc_resolve_array_constructor (gfc_expr * expr)
gfc_resolve_array_constructor (gfc_expr *expr)
{
try t;
......@@ -1612,7 +1610,7 @@ gfc_resolve_array_constructor (gfc_expr * expr)
/* Copy an iterator structure. */
static gfc_iterator *
copy_iterator (gfc_iterator * src)
copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
......@@ -1633,7 +1631,7 @@ copy_iterator (gfc_iterator * src)
/* Copy a constructor structure. */
gfc_constructor *
gfc_copy_constructor (gfc_constructor * src)
gfc_copy_constructor (gfc_constructor *src)
{
gfc_constructor *dest;
gfc_constructor *tail;
......@@ -1672,7 +1670,7 @@ gfc_copy_constructor (gfc_constructor * src)
have to be particularly fast. */
gfc_expr *
gfc_get_array_element (gfc_expr * array, int element)
gfc_get_array_element (gfc_expr *array, int element)
{
expand_info expand_save;
gfc_expr *e;
......@@ -1708,9 +1706,8 @@ gfc_get_array_element (gfc_expr * array, int element)
array is guaranteed to be one dimensional. */
static try
spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
{
if (as == NULL)
return FAILURE;
......@@ -1734,7 +1731,7 @@ spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
try
spec_size (gfc_array_spec * as, mpz_t * result)
spec_size (gfc_array_spec *as, mpz_t *result)
{
mpz_t size;
int d;
......@@ -1760,7 +1757,7 @@ spec_size (gfc_array_spec * as, mpz_t * result)
/* Get the number of elements in an array section. */
static try
ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
{
mpz_t upper, lower, stride;
try t;
......@@ -1848,7 +1845,7 @@ ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
static try
ref_size (gfc_array_ref * ar, mpz_t * result)
ref_size (gfc_array_ref *ar, mpz_t *result)
{
mpz_t size;
int d;
......@@ -1877,7 +1874,7 @@ ref_size (gfc_array_ref * ar, mpz_t * result)
otherwise. */
try
gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
{
gfc_ref *ref;
int i;
......@@ -1945,7 +1942,7 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
variable. Otherwise returns FAILURE. */
try
gfc_array_size (gfc_expr * array, mpz_t * result)
gfc_array_size (gfc_expr *array, mpz_t *result)
{
expand_info expand_save;
gfc_ref *ref;
......@@ -2010,7 +2007,7 @@ gfc_array_size (gfc_expr * array, mpz_t * result)
array of mpz_t integers. */
try
gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
{
int d;
int i;
......@@ -2055,14 +2052,13 @@ cleanup:
characterizes the reference. */
gfc_array_ref *
gfc_find_array_ref (gfc_expr * e)
gfc_find_array_ref (gfc_expr *e)
{
gfc_ref *ref;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
&& (ref->u.ar.type == AR_FULL
|| ref->u.ar.type == AR_SECTION))
&& (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
break;
if (ref == NULL)
......
gcc/fortran/bbt.c
/* Balanced binary trees using treaps.
Copyright (C) 2000, 2002, 2003 Free Software Foundation, Inc.
Copyright (C) 2000, 2002, 2003, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
......@@ -62,7 +63,7 @@ pseudo_random (void)
/* Rotate the treap left. */
static gfc_bbt *
rotate_left (gfc_bbt * t)
rotate_left (gfc_bbt *t)
{
gfc_bbt *temp;
......@@ -77,7 +78,7 @@ rotate_left (gfc_bbt * t)
/* Rotate the treap right. */
static gfc_bbt *
rotate_right (gfc_bbt * t)
rotate_right (gfc_bbt *t)
{
gfc_bbt *temp;
......@@ -93,7 +94,7 @@ rotate_right (gfc_bbt * t)
aborts if we find a duplicate key. */
static gfc_bbt *
insert (gfc_bbt * new, gfc_bbt * t, compare_fn compare)
insert (gfc_bbt *new, gfc_bbt *t, compare_fn compare)
{
int c;
......@@ -108,14 +109,12 @@ insert (gfc_bbt * new, gfc_bbt * t, compare_fn compare)
if (t->priority < t->left->priority)
t = rotate_right (t);
}
else if (c > 0)
{
t->right = insert (new, t->right, compare);
if (t->priority < t->right->priority)
t = rotate_left (t);
}
else /* if (c == 0) */
gfc_internal_error("insert_bbt(): Duplicate key found!");
......@@ -134,13 +133,12 @@ gfc_insert_bbt (void *root, void *new, compare_fn compare)
r = (gfc_bbt **) root;
n = (gfc_bbt *) new;
n->priority = pseudo_random ();
*r = insert (n, *r, compare);
}
static gfc_bbt *
delete_root (gfc_bbt * t)
delete_root (gfc_bbt *t)
{
gfc_bbt *temp;
......@@ -170,7 +168,7 @@ delete_root (gfc_bbt * t)
Returns the new root node of the tree. */
static gfc_bbt *
delete_treap (gfc_bbt * old, gfc_bbt * t, compare_fn compare)
delete_treap (gfc_bbt *old, gfc_bbt *t, compare_fn compare)
{
int c;
......@@ -196,6 +194,5 @@ gfc_delete_bbt (void *root, void *old, compare_fn compare)
gfc_bbt **t;
t = (gfc_bbt **) root;
*t = delete_treap ((gfc_bbt *) old, *t, compare);
}
gcc/fortran/check.c
/* Check functions
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 Andy Vaught & Katherine Holcomb
This file is part of GCC.
......@@ -36,7 +37,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
/* Check the type of an expression. */
static try
type_check (gfc_expr * e, int n, bt type)
type_check (gfc_expr *e, int n, bt type)
{
if (e->ts.type == type)
return SUCCESS;
......@@ -52,7 +53,7 @@ type_check (gfc_expr * e, int n, bt type)
/* Check that the expression is a numeric type. */
static try
numeric_check (gfc_expr * e, int n)
numeric_check (gfc_expr *e, int n)
{
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
......@@ -67,13 +68,13 @@ numeric_check (gfc_expr * e, int n)
/* Check that an expression is integer or real. */
static try
int_or_real_check (gfc_expr * e, int n)
int_or_real_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[n],
gfc_current_intrinsic, &e->where);
return FAILURE;
}
......@@ -84,13 +85,13 @@ int_or_real_check (gfc_expr * e, int n)
/* Check that an expression is real or complex. */
static try
real_or_complex_check (gfc_expr * e, int n)
real_or_complex_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
"or COMPLEX", gfc_current_intrinsic_arg[n],
gfc_current_intrinsic, &e->where);
return FAILURE;
}
......@@ -102,7 +103,7 @@ real_or_complex_check (gfc_expr * e, int n)
and that it specifies a valid kind for that type. */
static try
kind_check (gfc_expr * k, int n, bt type)
kind_check (gfc_expr *k, int n, bt type)
{
int kind;
......@@ -114,9 +115,9 @@ kind_check (gfc_expr * k, int n, bt type)
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&k->where);
return FAILURE;
}
......@@ -135,16 +136,16 @@ kind_check (gfc_expr * k, int n, bt type)
/* Make sure the expression is a double precision real. */
static try
double_check (gfc_expr * d, int n)
double_check (gfc_expr *d, int n)
{
if (type_check (d, n, BT_REAL) == FAILURE)
return FAILURE;
if (d->ts.kind != gfc_default_double_kind)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be double precision",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
"precision", gfc_current_intrinsic_arg[n],
gfc_current_intrinsic, &d->where);
return FAILURE;
}
......@@ -155,13 +156,13 @@ double_check (gfc_expr * d, int n)
/* Make sure the expression is a logical array. */
static try
logical_array_check (gfc_expr * array, int n)
logical_array_check (gfc_expr *array, int n)
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be a logical array",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
"array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&array->where);
return FAILURE;
}
......@@ -172,7 +173,7 @@ logical_array_check (gfc_expr * array, int n)
/* Make sure an expression is an array. */
static try
array_check (gfc_expr * e, int n)
array_check (gfc_expr *e, int n)
{
if (e->rank != 0)
return SUCCESS;
......@@ -187,7 +188,7 @@ array_check (gfc_expr * e, int n)
/* Make sure an expression is a scalar. */
static try
scalar_check (gfc_expr * e, int n)
scalar_check (gfc_expr *e, int n)
{
if (e->rank == 0)
return SUCCESS;
......@@ -202,7 +203,7 @@ scalar_check (gfc_expr * e, int n)
/* Make sure two expressions have the same type. */
static try
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
if (gfc_compare_types (&e->ts, &f->ts))
return SUCCESS;
......@@ -210,6 +211,7 @@ same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
"and kind as '%s'", gfc_current_intrinsic_arg[m],
gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
return FAILURE;
}
......@@ -217,7 +219,7 @@ same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
/* Make sure that an expression has a certain (nonzero) rank. */
static try
rank_check (gfc_expr * e, int n, int rank)
rank_check (gfc_expr *e, int n, int rank)
{
if (e->rank == rank)
return SUCCESS;
......@@ -225,6 +227,7 @@ rank_check (gfc_expr * e, int n, int rank)
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, rank);
return FAILURE;
}
......@@ -232,14 +235,13 @@ rank_check (gfc_expr * e, int n, int rank)
/* Make sure a variable expression is not an optional dummy argument. */
static try
nonoptional_check (gfc_expr * e, int n)
nonoptional_check (gfc_expr *e, int n)
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where);
}
/* TODO: Recursive check on nonoptional variables? */
......@@ -251,7 +253,7 @@ nonoptional_check (gfc_expr * e, int n)
/* Check that an expression has a particular kind. */
static try
kind_value_check (gfc_expr * e, int n, int k)
kind_value_check (gfc_expr *e, int n, int k)
{
if (e->ts.kind == k)
return SUCCESS;
......@@ -259,6 +261,7 @@ kind_value_check (gfc_expr * e, int n, int k)
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, k);
return FAILURE;
}
......@@ -266,7 +269,7 @@ kind_value_check (gfc_expr * e, int n, int k)
/* Make sure an expression is a variable. */
static try
variable_check (gfc_expr * e, int n)
variable_check (gfc_expr *e, int n)
{
if ((e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER)
......@@ -293,7 +296,7 @@ variable_check (gfc_expr * e, int n)
/* Check the common DIM parameter for correctness. */
static try
dim_check (gfc_expr * dim, int n, int optional)
dim_check (gfc_expr *dim, int n, int optional)
{
if (optional && dim == NULL)
return SUCCESS;
......@@ -324,7 +327,7 @@ dim_check (gfc_expr * dim, int n, int optional)
for assumed size arrays. */
static try
dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
{
gfc_array_ref *ar;
int rank;
......@@ -349,6 +352,7 @@ dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
return SUCCESS;
}
/* Compare the size of a along dimension ai with the size of b along
dimension bi, returning 0 if they are known not to be identical,
and 1 if they are identical, or if this cannot be determined. */
......@@ -378,6 +382,7 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
return ret;
}
/* Error return for transformational intrinsics not allowed in
initialization expressions. */
......@@ -396,7 +401,7 @@ non_init_transformational (void)
a kind argument for the result. */
static try
check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -406,24 +411,27 @@ check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
return SUCCESS;
}
/* Check subroutine suitable for ceiling, floor and nint. */
try
gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
{
return check_a_kind (a, kind, BT_INTEGER);
}
/* Check subroutine suitable for aint, anint. */
try
gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
{
return check_a_kind (a, kind, BT_REAL);
}
try
gfc_check_abs (gfc_expr * a)
gfc_check_abs (gfc_expr *a)
{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
......@@ -431,10 +439,10 @@ gfc_check_abs (gfc_expr * a)
return SUCCESS;
}
try
gfc_check_achar (gfc_expr * a)
gfc_check_achar (gfc_expr *a)
{
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -443,13 +451,12 @@ gfc_check_achar (gfc_expr * a)
try
gfc_check_access_func (gfc_expr * name, gfc_expr * mode)
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE
|| scalar_check (name, 0) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE
|| scalar_check (mode, 1) == FAILURE)
return FAILURE;
......@@ -459,7 +466,7 @@ gfc_check_access_func (gfc_expr * name, gfc_expr * mode)
try
gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
......@@ -475,7 +482,7 @@ gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
try
gfc_check_allocated (gfc_expr * array)
gfc_check_allocated (gfc_expr *array)
{
symbol_attribute attr;
......@@ -502,7 +509,7 @@ gfc_check_allocated (gfc_expr * array)
integer and the second argument must be the same as the first. */
try
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
{
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
......@@ -510,16 +517,16 @@ gfc_check_a_p (gfc_expr * a, gfc_expr * p)
if (a->ts.type != p->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&p->where);
"have the same type", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&p->where);
return FAILURE;
}
if (a->ts.kind != p->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
&p->where) == FAILURE)
&p->where) == FAILURE)
return FAILURE;
}
......@@ -528,7 +535,7 @@ gfc_check_a_p (gfc_expr * a, gfc_expr * p)
try
gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
symbol_attribute attr;
int i;
......@@ -590,14 +597,14 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
if (target->rank > 0)
{
for (i = 0; i < target->rank; i++)
if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
{
gfc_error ("Array section with a vector subscript at %L shall not "
if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
{
gfc_error ("Array section with a vector subscript at %L shall not "
"be the target of a pointer",
&target->where);
t = FAILURE;
break;
}
&target->where);
t = FAILURE;
break;
}
}
return t;
......@@ -611,7 +618,7 @@ null_arg:
try
gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
{
if (type_check (y, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -625,7 +632,7 @@ gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
/* BESJN and BESYN functions. */
try
gfc_check_besn (gfc_expr * n, gfc_expr * x)
gfc_check_besn (gfc_expr *n, gfc_expr *x)
{
if (scalar_check (n, 0) == FAILURE)
return FAILURE;
......@@ -644,7 +651,7 @@ gfc_check_besn (gfc_expr * n, gfc_expr * x)
try
gfc_check_btest (gfc_expr * i, gfc_expr * pos)
gfc_check_btest (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -656,7 +663,7 @@ gfc_check_btest (gfc_expr * i, gfc_expr * pos)
try
gfc_check_char (gfc_expr * i, gfc_expr * kind)
gfc_check_char (gfc_expr *i, gfc_expr *kind)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -668,7 +675,7 @@ gfc_check_char (gfc_expr * i, gfc_expr * kind)
try
gfc_check_chdir (gfc_expr * dir)
gfc_check_chdir (gfc_expr *dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -678,7 +685,7 @@ gfc_check_chdir (gfc_expr * dir)
try
gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -697,7 +704,7 @@ gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
try
gfc_check_chmod (gfc_expr * name, gfc_expr * mode)
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -710,7 +717,7 @@ gfc_check_chmod (gfc_expr * name, gfc_expr * mode)
try
gfc_check_chmod_sub (gfc_expr * name, gfc_expr * mode, gfc_expr * status)
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -732,7 +739,7 @@ gfc_check_chmod_sub (gfc_expr * name, gfc_expr * mode, gfc_expr * status)
try
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -759,13 +766,13 @@ gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
try
gfc_check_complex (gfc_expr * x, gfc_expr * y)
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &x->where);
return FAILURE;
}
if (scalar_check (x, 0) == FAILURE)
......@@ -773,9 +780,9 @@ gfc_check_complex (gfc_expr * x, gfc_expr * y)
if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &y->where);
return FAILURE;
}
if (scalar_check (y, 1) == FAILURE)
......@@ -786,7 +793,7 @@ gfc_check_complex (gfc_expr * x, gfc_expr * y)
try
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
gfc_check_count (gfc_expr *mask, gfc_expr *dim)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
......@@ -801,7 +808,7 @@ gfc_check_count (gfc_expr * mask, gfc_expr * dim)
try
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -827,7 +834,7 @@ gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
try
gfc_check_ctime (gfc_expr * time)
gfc_check_ctime (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
......@@ -840,7 +847,7 @@ gfc_check_ctime (gfc_expr * time)
try
gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -864,7 +871,7 @@ gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
try
gfc_check_dble (gfc_expr * x)
gfc_check_dble (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -874,7 +881,7 @@ gfc_check_dble (gfc_expr * x)
try
gfc_check_digits (gfc_expr * x)
gfc_check_digits (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
......@@ -884,7 +891,7 @@ gfc_check_digits (gfc_expr * x)
try
gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
switch (vector_a->ts.type)
{
......@@ -915,11 +922,9 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
{
gfc_error ("different shape for arguments '%s' and '%s' "
"at %L for intrinsic 'dot_product'",
gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1],
&vector_a->where);
gfc_error ("different shape for arguments '%s' and '%s' at %L for "
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], &vector_a->where);
return FAILURE;
}
......@@ -931,8 +936,8 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
try
gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
gfc_expr * dim)
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -971,7 +976,7 @@ gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
/* A single complex argument. */
try
gfc_check_fn_c (gfc_expr * a)
gfc_check_fn_c (gfc_expr *a)
{
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
return FAILURE;
......@@ -983,7 +988,7 @@ gfc_check_fn_c (gfc_expr * a)
/* A single real argument. */
try
gfc_check_fn_r (gfc_expr * a)
gfc_check_fn_r (gfc_expr *a)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -995,7 +1000,7 @@ gfc_check_fn_r (gfc_expr * a)
/* A single real or complex argument. */
try
gfc_check_fn_rc (gfc_expr * a)
gfc_check_fn_rc (gfc_expr *a)
{
if (real_or_complex_check (a, 0) == FAILURE)
return FAILURE;
......@@ -1005,7 +1010,7 @@ gfc_check_fn_rc (gfc_expr * a)
try
gfc_check_fnum (gfc_expr * unit)
gfc_check_fnum (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1021,7 +1026,7 @@ gfc_check_fnum (gfc_expr * unit)
error function. */
try
gfc_check_g77_math1 (gfc_expr * x)
gfc_check_g77_math1 (gfc_expr *x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
......@@ -1034,7 +1039,7 @@ gfc_check_g77_math1 (gfc_expr * x)
try
gfc_check_huge (gfc_expr * x)
gfc_check_huge (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
......@@ -1046,7 +1051,7 @@ gfc_check_huge (gfc_expr * x)
/* Check that the single argument is an integer. */
try
gfc_check_i (gfc_expr * i)
gfc_check_i (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1056,7 +1061,7 @@ gfc_check_i (gfc_expr * i)
try
gfc_check_iand (gfc_expr * i, gfc_expr * j)
gfc_check_iand (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1067,7 +1072,7 @@ gfc_check_iand (gfc_expr * i, gfc_expr * j)
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
&i->where) == FAILURE)
&i->where) == FAILURE)
return FAILURE;
}
......@@ -1076,7 +1081,7 @@ gfc_check_iand (gfc_expr * i, gfc_expr * j)
try
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1089,7 +1094,7 @@ gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
try
gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1105,7 +1110,7 @@ gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
try
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1118,7 +1123,7 @@ gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
try
gfc_check_ichar_iachar (gfc_expr * c)
gfc_check_ichar_iachar (gfc_expr *c)
{
int i;
......@@ -1140,7 +1145,7 @@ gfc_check_ichar_iachar (gfc_expr * c)
if (!ref)
{
/* Check that the argument is length one. Non-constant lengths
/* Check that the argument is length one. Non-constant lengths
can't be checked here, so assume they are ok. */
if (c->ts.cl && c->ts.cl->length)
{
......@@ -1163,7 +1168,7 @@ gfc_check_ichar_iachar (gfc_expr * c)
return SUCCESS;
i = mpz_get_si (end->value.integer) + 1
- mpz_get_si (start->value.integer);
- mpz_get_si (start->value.integer);
}
}
else
......@@ -1181,7 +1186,7 @@ gfc_check_ichar_iachar (gfc_expr * c)
try
gfc_check_idnint (gfc_expr * a)
gfc_check_idnint (gfc_expr *a)
{
if (double_check (a, 0) == FAILURE)
return FAILURE;
......@@ -1191,7 +1196,7 @@ gfc_check_idnint (gfc_expr * a)
try
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
gfc_check_ieor (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1202,7 +1207,7 @@ gfc_check_ieor (gfc_expr * i, gfc_expr * j)
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
&i->where) == FAILURE)
&i->where) == FAILURE)
return FAILURE;
}
......@@ -1211,7 +1216,7 @@ gfc_check_ieor (gfc_expr * i, gfc_expr * j)
try
gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
......@@ -1235,7 +1240,7 @@ gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
try
gfc_check_int (gfc_expr * x, gfc_expr * kind)
gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -1243,7 +1248,7 @@ gfc_check_int (gfc_expr * x, gfc_expr * kind)
if (kind != NULL)
{
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return FAILURE;
if (scalar_check (kind, 1) == FAILURE)
return FAILURE;
......@@ -1254,7 +1259,7 @@ gfc_check_int (gfc_expr * x, gfc_expr * kind)
try
gfc_check_intconv (gfc_expr * x)
gfc_check_intconv (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -1264,7 +1269,7 @@ gfc_check_intconv (gfc_expr * x)
try
gfc_check_ior (gfc_expr * i, gfc_expr * j)
gfc_check_ior (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1275,8 +1280,8 @@ gfc_check_ior (gfc_expr * i, gfc_expr * j)
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
&i->where) == FAILURE)
return FAILURE;
&i->where) == FAILURE)
return FAILURE;
}
return SUCCESS;
......@@ -1284,7 +1289,7 @@ gfc_check_ior (gfc_expr * i, gfc_expr * j)
try
gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
......@@ -1295,7 +1300,7 @@ gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
try
gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
......@@ -1309,7 +1314,7 @@ gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
try
gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1322,7 +1327,7 @@ gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
try
gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1350,7 +1355,7 @@ gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
try
gfc_check_kind (gfc_expr * x)
gfc_check_kind (gfc_expr *x)
{
if (x->ts.type == BT_DERIVED)
{
......@@ -1365,7 +1370,7 @@ gfc_check_kind (gfc_expr * x)
try
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -1383,7 +1388,7 @@ gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
try
gfc_check_link (gfc_expr * path1, gfc_expr * path2)
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -1396,7 +1401,7 @@ gfc_check_link (gfc_expr * path1, gfc_expr * path2)
try
gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -1416,6 +1421,7 @@ gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
return SUCCESS;
}
try
gfc_check_loc (gfc_expr *expr)
{
......@@ -1424,7 +1430,7 @@ gfc_check_loc (gfc_expr *expr)
try
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -1437,7 +1443,7 @@ gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
try
gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -1459,7 +1465,7 @@ gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
try
gfc_check_logical (gfc_expr * a, gfc_expr * kind)
gfc_check_logical (gfc_expr *a, gfc_expr *kind)
{
if (type_check (a, 0, BT_LOGICAL) == FAILURE)
return FAILURE;
......@@ -1473,7 +1479,7 @@ gfc_check_logical (gfc_expr * a, gfc_expr * kind)
/* Min/max family. */
static try
min_max_args (gfc_actual_arglist * arg)
min_max_args (gfc_actual_arglist *arg)
{
if (arg == NULL || arg->next == NULL)
{
......@@ -1487,7 +1493,7 @@ min_max_args (gfc_actual_arglist * arg)
static try
check_rest (bt type, int kind, gfc_actual_arglist * arg)
check_rest (bt type, int kind, gfc_actual_arglist *arg)
{
gfc_expr *x;
int n;
......@@ -1502,20 +1508,19 @@ check_rest (bt type, int kind, gfc_actual_arglist * arg)
x = arg->expr;
if (x->ts.type != type || x->ts.kind != kind)
{
if (x->ts.type == type)
{
if (gfc_notify_std (GFC_STD_GNU,
"Extension: Different type kinds at %L", &x->where)
== FAILURE)
if (x->ts.type == type)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
"kinds at %L", &x->where) == FAILURE)
return FAILURE;
}
else
{
gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return FAILURE;
}
}
else
{
gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
"%s(%d)", n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return FAILURE;
}
}
}
......@@ -1524,7 +1529,7 @@ check_rest (bt type, int kind, gfc_actual_arglist * arg)
try
gfc_check_min_max (gfc_actual_arglist * arg)
gfc_check_min_max (gfc_actual_arglist *arg)
{
gfc_expr *x;
......@@ -1535,9 +1540,8 @@ gfc_check_min_max (gfc_actual_arglist * arg)
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error
("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic, &x->where);
gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic, &x->where);
return FAILURE;
}
......@@ -1546,29 +1550,30 @@ gfc_check_min_max (gfc_actual_arglist * arg)
try
gfc_check_min_max_integer (gfc_actual_arglist * arg)
gfc_check_min_max_integer (gfc_actual_arglist *arg)
{
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
}
try
gfc_check_min_max_real (gfc_actual_arglist * arg)
gfc_check_min_max_real (gfc_actual_arglist *arg)
{
return check_rest (BT_REAL, gfc_default_real_kind, arg);
}
try
gfc_check_min_max_double (gfc_actual_arglist * arg)
gfc_check_min_max_double (gfc_actual_arglist *arg)
{
return check_rest (BT_REAL, gfc_default_double_kind, arg);
}
/* End of min/max family. */
try
gfc_check_malloc (gfc_expr * size)
gfc_check_malloc (gfc_expr *size)
{
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -1581,7 +1586,7 @@ gfc_check_malloc (gfc_expr * size)
try
gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
{
......@@ -1605,13 +1610,12 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
{
gfc_error ("different shape on dimension 1 for arguments '%s' "
"and '%s' at %L for intrinsic matmul",
gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1],
&matrix_a->where);
gfc_current_intrinsic_arg[1], &matrix_a->where);
return FAILURE;
}
break;
......@@ -1625,7 +1629,7 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
/* matrix_b has rank 1 or 2 here. Common check for the cases
- matrix_a has shape (n,m) and matrix_b has shape (m, k)
- matrix_a has shape (n,m) and matrix_b has shape (m). */
if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
gfc_error ("different shape on dimension 2 for argument '%s' and "
"dimension 1 for argument '%s' at %L for intrinsic "
......@@ -1653,24 +1657,23 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
The possibilities for the occupation of the second and third
parameters are:
Arg #2 Arg #3
NULL NULL
DIM NULL
MASK NULL
NULL MASK minloc(array, mask=m)
DIM MASK
Arg #2 Arg #3
NULL NULL
DIM NULL
MASK NULL
NULL MASK minloc(array, mask=m)
DIM MASK
I.e. in the case of minloc(array,mask), mask will be in the second
position of the argument list and we'll have to fix that up. */
try
gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
{
gfc_expr *a, *m, *d;
a = ap->expr;
if (int_or_real_check (a, 0) == FAILURE
|| array_check (a, 0) == FAILURE)
if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
return FAILURE;
d = ap->next->expr;
......@@ -1681,7 +1684,6 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
{
m = d;
d = NULL;
ap->next->expr = NULL;
ap->next->next->expr = m;
}
......@@ -1698,9 +1700,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
if (m != NULL)
{
char buffer[80];
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, a, m) == FAILURE)
return FAILURE;
}
......@@ -1717,18 +1719,18 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
difference is that MINLOC/MAXLOC take an additional KIND argument.
The possibilities are:
Arg #2 Arg #3
NULL NULL
DIM NULL
MASK NULL
NULL MASK minval(array, mask=m)
DIM MASK
Arg #2 Arg #3
NULL NULL
DIM NULL
MASK NULL
NULL MASK minval(array, mask=m)
DIM MASK
I.e. in the case of minval(array,mask), mask will be in the second
position of the argument list and we'll have to fix that up. */
static try
check_reduction (gfc_actual_arglist * ap)
check_reduction (gfc_actual_arglist *ap)
{
gfc_expr *a, *m, *d;
......@@ -1741,7 +1743,6 @@ check_reduction (gfc_actual_arglist * ap)
{
m = d;
d = NULL;
ap->next->expr = NULL;
ap->next->next->expr = m;
}
......@@ -1758,9 +1759,9 @@ check_reduction (gfc_actual_arglist * ap)
if (m != NULL)
{
char buffer[80];
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, a, m) == FAILURE)
return FAILURE;
}
......@@ -1770,7 +1771,7 @@ check_reduction (gfc_actual_arglist * ap)
try
gfc_check_minval_maxval (gfc_actual_arglist * ap)
gfc_check_minval_maxval (gfc_actual_arglist *ap)
{
if (int_or_real_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
......@@ -1784,7 +1785,7 @@ gfc_check_minval_maxval (gfc_actual_arglist * ap)
try
gfc_check_product_sum (gfc_actual_arglist * ap)
gfc_check_product_sum (gfc_actual_arglist *ap)
{
if (numeric_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
......@@ -1798,7 +1799,7 @@ gfc_check_product_sum (gfc_actual_arglist * ap)
try
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
char buffer[80];
......@@ -1808,15 +1809,15 @@ gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
return FAILURE;
......@@ -1824,7 +1825,7 @@ gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
}
try
gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
{
symbol_attribute attr;
......@@ -1882,8 +1883,9 @@ gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
return SUCCESS;
}
try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
gfc_check_nearest (gfc_expr *x, gfc_expr *s)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -1894,8 +1896,9 @@ gfc_check_nearest (gfc_expr * x, gfc_expr * s)
return SUCCESS;
}
try
gfc_check_new_line (gfc_expr * a)
gfc_check_new_line (gfc_expr *a)
{
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -1903,8 +1906,9 @@ gfc_check_new_line (gfc_expr * a)
return SUCCESS;
}
try
gfc_check_null (gfc_expr * mold)
gfc_check_null (gfc_expr *mold)
{
symbol_attribute attr;
......@@ -1929,7 +1933,7 @@ gfc_check_null (gfc_expr * mold)
try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
{
char buffer[80];
......@@ -1939,9 +1943,9 @@ gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, array, mask) == FAILURE)
return FAILURE;
......@@ -1964,7 +1968,7 @@ gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
try
gfc_check_precision (gfc_expr * x)
gfc_check_precision (gfc_expr *x)
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
......@@ -1979,7 +1983,7 @@ gfc_check_precision (gfc_expr * x)
try
gfc_check_present (gfc_expr * a)
gfc_check_present (gfc_expr *a)
{
gfc_symbol *sym;
......@@ -2003,18 +2007,18 @@ gfc_check_present (gfc_expr * a)
return FAILURE;
}
/* 13.14.82 PRESENT(A)
......
Argument. A shall be the name of an optional dummy argument that is accessible
in the subprogram in which the PRESENT function reference appears... */
/* 13.14.82 PRESENT(A)
......
Argument. A shall be the name of an optional dummy argument that is
accessible in the subprogram in which the PRESENT function reference
appears... */
if (a->ref != NULL
&& !(a->ref->next == NULL
&& a->ref->type == REF_ARRAY
&& a->ref->u.ar.type == AR_FULL))
&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
&& a->ref->u.ar.type == AR_FULL))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
"object of '%s'", gfc_current_intrinsic_arg[0],
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
"subobject of '%s'", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &a->where, sym->name);
return FAILURE;
}
......@@ -2024,7 +2028,7 @@ gfc_check_present (gfc_expr * a)
try
gfc_check_radix (gfc_expr * x)
gfc_check_radix (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
......@@ -2034,7 +2038,7 @@ gfc_check_radix (gfc_expr * x)
try
gfc_check_range (gfc_expr * x)
gfc_check_range (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
......@@ -2045,7 +2049,7 @@ gfc_check_range (gfc_expr * x)
/* real, float, sngl. */
try
gfc_check_real (gfc_expr * a, gfc_expr * kind)
gfc_check_real (gfc_expr *a, gfc_expr *kind)
{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
......@@ -2058,7 +2062,7 @@ gfc_check_real (gfc_expr * a, gfc_expr * kind)
try
gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2071,7 +2075,7 @@ gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
try
gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2093,7 +2097,7 @@ gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
try
gfc_check_repeat (gfc_expr * x, gfc_expr * y)
gfc_check_repeat (gfc_expr *x, gfc_expr *y)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2112,8 +2116,8 @@ gfc_check_repeat (gfc_expr * x, gfc_expr * y)
try
gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
gfc_expr * pad, gfc_expr * order)
gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
gfc_expr *pad, gfc_expr *order)
{
mpz_t size;
mpz_t nelems;
......@@ -2156,12 +2160,10 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
if (order != NULL && array_check (order, 3) == FAILURE)
return FAILURE;
if (pad == NULL
&& shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
&& !(source->expr_type == EXPR_VARIABLE
&& source->symtree->n.sym->as
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
if (pad == NULL && shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
&& !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
{
/* Check the match in size between source and destination. */
if (gfc_array_size (source, &nelems) == SUCCESS)
......@@ -2180,9 +2182,9 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
if (test)
{
gfc_error ("Without padding, there are not enough elements in the "
"intrinsic RESHAPE source at %L to match the shape",
&source->where);
gfc_error ("Without padding, there are not enough elements "
"in the intrinsic RESHAPE source at %L to match "
"the shape", &source->where);
return FAILURE;
}
}
......@@ -2193,7 +2195,7 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
try
gfc_check_scale (gfc_expr * x, gfc_expr * i)
gfc_check_scale (gfc_expr *x, gfc_expr *i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -2206,7 +2208,7 @@ gfc_check_scale (gfc_expr * x, gfc_expr * i)
try
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2225,9 +2227,8 @@ gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
try
gfc_check_secnds (gfc_expr * r)
gfc_check_secnds (gfc_expr *r)
{
if (type_check (r, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -2242,9 +2243,8 @@ gfc_check_secnds (gfc_expr * r)
try
gfc_check_selected_int_kind (gfc_expr * r)
gfc_check_selected_int_kind (gfc_expr *r)
{
if (type_check (r, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2256,7 +2256,7 @@ gfc_check_selected_int_kind (gfc_expr * r)
try
gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
{
if (p == NULL && r == NULL)
{
......@@ -2277,7 +2277,7 @@ gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
try
gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -2290,7 +2290,7 @@ gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
try
gfc_check_shape (gfc_expr * source)
gfc_check_shape (gfc_expr *source)
{
gfc_array_ref *ar;
......@@ -2311,7 +2311,7 @@ gfc_check_shape (gfc_expr * source)
try
gfc_check_sign (gfc_expr * a, gfc_expr * b)
gfc_check_sign (gfc_expr *a, gfc_expr *b)
{
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
......@@ -2324,7 +2324,7 @@ gfc_check_sign (gfc_expr * a, gfc_expr * b)
try
gfc_check_size (gfc_expr * array, gfc_expr * dim)
gfc_check_size (gfc_expr *array, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -2346,7 +2346,7 @@ gfc_check_size (gfc_expr * array, gfc_expr * dim)
try
gfc_check_sleep_sub (gfc_expr * seconds)
gfc_check_sleep_sub (gfc_expr *seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2359,7 +2359,7 @@ gfc_check_sleep_sub (gfc_expr * seconds)
try
gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
if (source->rank >= GFC_MAX_DIMENSIONS)
{
......@@ -2388,8 +2388,9 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
functions). */
try
gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2413,14 +2414,14 @@ gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
try
gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
{
return gfc_check_fgetputc_sub (unit, c, NULL);
}
try
gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
{
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2438,14 +2439,14 @@ gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
try
gfc_check_fgetput (gfc_expr * c)
gfc_check_fgetput (gfc_expr *c)
{
return gfc_check_fgetput_sub (c, NULL);
}
try
gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2465,7 +2466,7 @@ gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
try
gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2495,7 +2496,7 @@ gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
try
gfc_check_ftell (gfc_expr * unit)
gfc_check_ftell (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2508,7 +2509,7 @@ gfc_check_ftell (gfc_expr * unit)
try
gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2527,7 +2528,7 @@ gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
try
gfc_check_stat (gfc_expr * name, gfc_expr * array)
gfc_check_stat (gfc_expr *name, gfc_expr *array)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2544,7 +2545,7 @@ gfc_check_stat (gfc_expr * name, gfc_expr * array)
try
gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2571,9 +2572,8 @@ gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
try
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
gfc_expr * mold ATTRIBUTE_UNUSED,
gfc_expr * size)
gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
{
if (size != NULL)
{
......@@ -2592,7 +2592,7 @@ gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
try
gfc_check_transpose (gfc_expr * matrix)
gfc_check_transpose (gfc_expr *matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
......@@ -2605,7 +2605,7 @@ gfc_check_transpose (gfc_expr * matrix)
try
gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -2624,7 +2624,7 @@ gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
try
gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
if (rank_check (vector, 0, 1) == FAILURE)
return FAILURE;
......@@ -2646,7 +2646,7 @@ gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
try
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2662,7 +2662,7 @@ gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
try
gfc_check_trim (gfc_expr * x)
gfc_check_trim (gfc_expr *x)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2675,7 +2675,7 @@ gfc_check_trim (gfc_expr * x)
try
gfc_check_ttynam (gfc_expr * unit)
gfc_check_ttynam (gfc_expr *unit)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
......@@ -2691,7 +2691,7 @@ gfc_check_ttynam (gfc_expr * unit)
single real argument. */
try
gfc_check_x (gfc_expr * x)
gfc_check_x (gfc_expr *x)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -2703,7 +2703,7 @@ gfc_check_x (gfc_expr * x)
/************* Check functions for intrinsic subroutines *************/
try
gfc_check_cpu_time (gfc_expr * time)
gfc_check_cpu_time (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
......@@ -2719,8 +2719,8 @@ gfc_check_cpu_time (gfc_expr * time)
try
gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
gfc_expr * zone, gfc_expr * values)
gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
gfc_expr *zone, gfc_expr *values)
{
if (date != NULL)
{
......@@ -2769,8 +2769,8 @@ gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
try
gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
gfc_expr * to, gfc_expr * topos)
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
gfc_expr *to, gfc_expr *topos)
{
if (type_check (from, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -2795,7 +2795,7 @@ gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
try
gfc_check_random_number (gfc_expr * harvest)
gfc_check_random_number (gfc_expr *harvest)
{
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
......@@ -2808,7 +2808,7 @@ gfc_check_random_number (gfc_expr * harvest)
try
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
if (size != NULL)
{
......@@ -2829,8 +2829,8 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
{
if (size != NULL)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&put->where);
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&put->where);
if (array_check (put, 1) == FAILURE)
return FAILURE;
......@@ -2849,8 +2849,8 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
{
if (size != NULL || put != NULL)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&get->where);
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&get->where);
if (array_check (get, 2) == FAILURE)
return FAILURE;
......@@ -2871,8 +2871,9 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
return SUCCESS;
}
try
gfc_check_second_sub (gfc_expr * time)
gfc_check_second_sub (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
......@@ -2891,63 +2892,64 @@ gfc_check_second_sub (gfc_expr * time)
count, count_rate, and count_max are all optional arguments */
try
gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
gfc_expr * count_max)
gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
gfc_expr *count_max)
{
if (count != NULL)
{
if (scalar_check (count, 0) == FAILURE)
return FAILURE;
return FAILURE;
if (type_check (count, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return FAILURE;
if (variable_check (count, 0) == FAILURE)
return FAILURE;
return FAILURE;
}
if (count_rate != NULL)
{
if (scalar_check (count_rate, 1) == FAILURE)
return FAILURE;
return FAILURE;
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return FAILURE;
if (variable_check (count_rate, 1) == FAILURE)
return FAILURE;
return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_rate, 1) == FAILURE)
return FAILURE;
return FAILURE;
}
if (count_max != NULL)
{
if (scalar_check (count_max, 2) == FAILURE)
return FAILURE;
return FAILURE;
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
return FAILURE;
return FAILURE;
if (variable_check (count_max, 2) == FAILURE)
return FAILURE;
return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_max, 2) == FAILURE)
return FAILURE;
return FAILURE;
if (count_rate != NULL
&& same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
&& same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_irand (gfc_expr * x)
gfc_check_irand (gfc_expr *x)
{
if (x == NULL)
return SUCCESS;
......@@ -2966,7 +2968,7 @@ gfc_check_irand (gfc_expr * x)
try
gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
{
if (scalar_check (seconds, 0) == FAILURE)
return FAILURE;
......@@ -2976,9 +2978,9 @@ gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &handler->where);
return FAILURE;
}
......@@ -2999,7 +3001,7 @@ gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
try
gfc_check_rand (gfc_expr * x)
gfc_check_rand (gfc_expr *x)
{
if (x == NULL)
return SUCCESS;
......@@ -3016,8 +3018,9 @@ gfc_check_rand (gfc_expr * x)
return SUCCESS;
}
try
gfc_check_srand (gfc_expr * x)
gfc_check_srand (gfc_expr *x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
......@@ -3031,8 +3034,9 @@ gfc_check_srand (gfc_expr * x)
return SUCCESS;
}
try
gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
......@@ -3046,8 +3050,9 @@ gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
return SUCCESS;
}
try
gfc_check_etime (gfc_expr * x)
gfc_check_etime (gfc_expr *x)
{
if (array_check (x, 0) == FAILURE)
return FAILURE;
......@@ -3067,8 +3072,9 @@ gfc_check_etime (gfc_expr * x)
return SUCCESS;
}
try
gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
......@@ -3099,7 +3105,7 @@ gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
try
gfc_check_fdate_sub (gfc_expr * date)
gfc_check_fdate_sub (gfc_expr *date)
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3109,7 +3115,7 @@ gfc_check_fdate_sub (gfc_expr * date)
try
gfc_check_gerror (gfc_expr * msg)
gfc_check_gerror (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3119,7 +3125,7 @@ gfc_check_gerror (gfc_expr * msg)
try
gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
{
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3138,7 +3144,7 @@ gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
try
gfc_check_getlog (gfc_expr * msg)
gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3148,7 +3154,7 @@ gfc_check_getlog (gfc_expr * msg)
try
gfc_check_exit (gfc_expr * status)
gfc_check_exit (gfc_expr *status)
{
if (status == NULL)
return SUCCESS;
......@@ -3164,7 +3170,7 @@ gfc_check_exit (gfc_expr * status)
try
gfc_check_flush (gfc_expr * unit)
gfc_check_flush (gfc_expr *unit)
{
if (unit == NULL)
return SUCCESS;
......@@ -3180,7 +3186,7 @@ gfc_check_flush (gfc_expr * unit)
try
gfc_check_free (gfc_expr * i)
gfc_check_free (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -3193,7 +3199,7 @@ gfc_check_free (gfc_expr * i)
try
gfc_check_hostnm (gfc_expr * name)
gfc_check_hostnm (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3203,7 +3209,7 @@ gfc_check_hostnm (gfc_expr * name)
try
gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3222,7 +3228,7 @@ gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
try
gfc_check_itime_idate (gfc_expr * values)
gfc_check_itime_idate (gfc_expr *values)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
......@@ -3244,7 +3250,7 @@ gfc_check_itime_idate (gfc_expr * values)
try
gfc_check_ltime_gmtime (gfc_expr * time, gfc_expr * values)
gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
{
if (type_check (time, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -3275,7 +3281,7 @@ gfc_check_ltime_gmtime (gfc_expr * time, gfc_expr * values)
try
gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
......@@ -3291,7 +3297,7 @@ gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
try
gfc_check_isatty (gfc_expr * unit)
gfc_check_isatty (gfc_expr *unit)
{
if (unit == NULL)
return FAILURE;
......@@ -3307,7 +3313,7 @@ gfc_check_isatty (gfc_expr * unit)
try
gfc_check_perror (gfc_expr * string)
gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3317,7 +3323,7 @@ gfc_check_perror (gfc_expr * string)
try
gfc_check_umask (gfc_expr * mask)
gfc_check_umask (gfc_expr *mask)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -3330,7 +3336,7 @@ gfc_check_umask (gfc_expr * mask)
try
gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
......@@ -3352,7 +3358,7 @@ gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
try
gfc_check_unlink (gfc_expr * name)
gfc_check_unlink (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3362,7 +3368,7 @@ gfc_check_unlink (gfc_expr * name)
try
gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3381,7 +3387,7 @@ gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
try
gfc_check_signal (gfc_expr * number, gfc_expr * handler)
gfc_check_signal (gfc_expr *number, gfc_expr *handler)
{
if (scalar_check (number, 0) == FAILURE)
return FAILURE;
......@@ -3391,9 +3397,9 @@ gfc_check_signal (gfc_expr * number, gfc_expr * handler)
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &handler->where);
return FAILURE;
}
......@@ -3405,7 +3411,7 @@ gfc_check_signal (gfc_expr * number, gfc_expr * handler)
try
gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
{
if (scalar_check (number, 0) == FAILURE)
return FAILURE;
......@@ -3415,9 +3421,9 @@ gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &handler->where);
return FAILURE;
}
......@@ -3438,7 +3444,7 @@ gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
try
gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
{
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -3458,21 +3464,21 @@ gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
/* This is used for the GNU intrinsics AND, OR and XOR. */
try
gfc_check_and (gfc_expr * i, gfc_expr * j)
gfc_check_and (gfc_expr *i, gfc_expr *j)
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &i->where);
return FAILURE;
}
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &j->where);
return FAILURE;
}
......
gcc/testsuite/ChangeLog
2006-01-06 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.dg/present_1.f90: Update error message.
2006-01-06 Lee Millward <lee.millward@codesourcery.com>
PR c++/19439
gcc/testsuite/gfortran.dg/present_1.f90
......@@ -11,8 +11,8 @@
CONTAINS
SUBROUTINE S1(D1)
TYPE(T1), OPTIONAL :: D1(4)
write(6,*) PRESENT(D1%I) ! { dg-error "must not be a sub-object" }
write(6,*) PRESENT(D1(1)) ! { dg-error "must not be a sub-object" }
write(6,*) PRESENT(D1%I) ! { dg-error "must not be a subobject" }
write(6,*) PRESENT(D1(1)) ! { dg-error "must not be a subobject" }
write(6,*) PRESENT(D1)
END SUBROUTINE S1
END MODULE
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment