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