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