/* 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.
/* 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;
expression. */
static match
-match_subscript (gfc_array_ref * ar, int init)
+match_subscript (gfc_array_ref *ar, int init)
{
match m;
int i;
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");
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;
specifications. */
void
-gfc_free_array_spec (gfc_array_spec * as)
+gfc_free_array_spec (gfc_array_spec *as)
{
int i;
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;
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;
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.
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;
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;
}
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;
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;
|| (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:
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;
/* 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;
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
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;
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;
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;
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;
{
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;
+ }
}
}
/* Free chains of gfc_constructor structures. */
void
-gfc_free_constructor (gfc_constructor * p)
+gfc_free_constructor (gfc_constructor *p)
{
gfc_constructor *next;
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);
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;
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;
}
/* 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;
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;
/* 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;
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 = " /)";
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 */
/* 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;
On FAILURE, an error has been generated. */
try
-gfc_check_constructor_type (gfc_expr * e)
+gfc_check_constructor_type (gfc_expr *e)
{
try t;
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;
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;
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;
constructor. */
static try
-count_elements (gfc_expr * e)
+count_elements (gfc_expr *e)
{
mpz_t result;
constructor, freeing the rest. */
static try
-extract_element (gfc_expr * e)
+extract_element (gfc_expr *e)
{
if (e->rank != 0)
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 ();
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;
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);
static try
-expand_iterator (gfc_constructor * c)
+expand_iterator (gfc_constructor *c)
{
gfc_expr *start, *end, *step;
iterator_stack frame;
passed expression. */
static try
-expand_constructor (gfc_constructor * c)
+expand_constructor (gfc_constructor *c)
{
gfc_expr *e;
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;
FAILURE if not so. */
static try
-constant_element (gfc_expr * e)
+constant_element (gfc_expr *e)
{
int rv;
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;
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;
be of the same type. */
static try
-resolve_array_list (gfc_constructor * p)
+resolve_array_list (gfc_constructor *p)
{
try t;
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);
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;
}
}
}
+
/* 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;
/* Copy an iterator structure. */
static gfc_iterator *
-copy_iterator (gfc_iterator * src)
+copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
/* Copy a constructor structure. */
gfc_constructor *
-gfc_copy_constructor (gfc_constructor * src)
+gfc_copy_constructor (gfc_constructor *src)
{
gfc_constructor *dest;
gfc_constructor *tail;
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;
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;
try
-spec_size (gfc_array_spec * as, mpz_t * result)
+spec_size (gfc_array_spec *as, mpz_t *result)
{
mpz_t size;
int d;
/* 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;
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;
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;
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;
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;
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)
/* 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.
/* 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;
/* 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;
/* 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;
}
/* 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;
}
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;
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;
}
/* 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;
}
/* 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;
}
/* 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;
/* 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;
/* 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;
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;
}
/* 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;
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;
}
/* 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? */
/* 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;
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;
}
/* 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)
/* 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;
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;
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. */
return ret;
}
+
/* Error return for transformational intrinsics not allowed in
initialization expressions. */
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;
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;
return SUCCESS;
}
+
try
-gfc_check_achar (gfc_expr * a)
+gfc_check_achar (gfc_expr *a)
{
-
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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;
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;
try
-gfc_check_allocated (gfc_expr * array)
+gfc_check_allocated (gfc_expr *array)
{
symbol_attribute attr;
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;
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;
}
try
-gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
+gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
symbol_attribute attr;
int i;
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;
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;
/* 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;
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;
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;
try
-gfc_check_chdir (gfc_expr * dir)
+gfc_check_chdir (gfc_expr *dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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;
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;
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;
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;
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)
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)
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;
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;
try
-gfc_check_ctime (gfc_expr * time)
+gfc_check_ctime (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
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;
try
-gfc_check_dble (gfc_expr * x)
+gfc_check_dble (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_digits (gfc_expr * x)
+gfc_check_digits (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
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)
{
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;
}
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;
/* 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;
/* 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;
/* 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;
try
-gfc_check_fnum (gfc_expr * unit)
+gfc_check_fnum (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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;
try
-gfc_check_huge (gfc_expr * x)
+gfc_check_huge (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
/* 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;
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;
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;
}
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;
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;
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;
try
-gfc_check_ichar_iachar (gfc_expr * c)
+gfc_check_ichar_iachar (gfc_expr *c)
{
int i;
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)
{
return SUCCESS;
i = mpz_get_si (end->value.integer) + 1
- - mpz_get_si (start->value.integer);
+ - mpz_get_si (start->value.integer);
}
}
else
try
-gfc_check_idnint (gfc_expr * a)
+gfc_check_idnint (gfc_expr *a)
{
if (double_check (a, 0) == FAILURE)
return FAILURE;
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;
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;
}
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)
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;
if (kind != NULL)
{
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (scalar_check (kind, 1) == FAILURE)
return FAILURE;
try
-gfc_check_intconv (gfc_expr * x)
+gfc_check_intconv (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
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;
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;
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)
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)
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;
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;
try
-gfc_check_kind (gfc_expr * x)
+gfc_check_kind (gfc_expr *x)
{
if (x->ts.type == BT_DERIVED)
{
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;
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;
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;
return SUCCESS;
}
+
try
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;
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;
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;
/* 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)
{
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;
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;
+ }
}
}
try
-gfc_check_min_max (gfc_actual_arglist * arg)
+gfc_check_min_max (gfc_actual_arglist *arg)
{
gfc_expr *x;
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;
}
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;
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 (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;
/* 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 "
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;
{
m = d;
d = NULL;
-
ap->next->expr = NULL;
ap->next->next->expr = m;
}
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;
}
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;
{
m = d;
d = NULL;
-
ap->next->expr = NULL;
ap->next->next->expr = m;
}
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;
}
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)
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)
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];
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;
}
try
-gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
{
symbol_attribute attr;
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;
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;
return SUCCESS;
}
+
try
-gfc_check_null (gfc_expr * mold)
+gfc_check_null (gfc_expr *mold)
{
symbol_attribute attr;
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];
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;
try
-gfc_check_precision (gfc_expr * x)
+gfc_check_precision (gfc_expr *x)
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
try
-gfc_check_present (gfc_expr * a)
+gfc_check_present (gfc_expr *a)
{
gfc_symbol *sym;
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;
}
try
-gfc_check_radix (gfc_expr * x)
+gfc_check_radix (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_range (gfc_expr * x)
+gfc_check_range (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
/* 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;
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;
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;
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;
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;
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)
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;
}
}
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;
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;
try
-gfc_check_secnds (gfc_expr * r)
+gfc_check_secnds (gfc_expr *r)
{
-
if (type_check (r, 0, BT_REAL) == FAILURE)
return FAILURE;
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;
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)
{
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;
try
-gfc_check_shape (gfc_expr * source)
+gfc_check_shape (gfc_expr *source)
{
gfc_array_ref *ar;
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;
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;
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;
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)
{
/* 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;
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;
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;
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;
try
-gfc_check_ftell (gfc_expr * unit)
+gfc_check_ftell (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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;
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;
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;
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)
{
try
-gfc_check_transpose (gfc_expr * matrix)
+gfc_check_transpose (gfc_expr *matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
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;
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;
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;
try
-gfc_check_trim (gfc_expr * x)
+gfc_check_trim (gfc_expr *x)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_ttynam (gfc_expr * unit)
+gfc_check_ttynam (gfc_expr *unit)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
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;
/************* 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;
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)
{
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;
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;
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)
- 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;
{
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;
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;
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;
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;
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;
}
try
-gfc_check_rand (gfc_expr * x)
+gfc_check_rand (gfc_expr *x)
{
if (x == NULL)
return SUCCESS;
return SUCCESS;
}
+
try
-gfc_check_srand (gfc_expr * x)
+gfc_check_srand (gfc_expr *x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
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;
return SUCCESS;
}
+
try
-gfc_check_etime (gfc_expr * x)
+gfc_check_etime (gfc_expr *x)
{
if (array_check (x, 0) == FAILURE)
return FAILURE;
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;
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;
try
-gfc_check_gerror (gfc_expr * msg)
+gfc_check_gerror (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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;
try
-gfc_check_getlog (gfc_expr * msg)
+gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_exit (gfc_expr * status)
+gfc_check_exit (gfc_expr *status)
{
if (status == NULL)
return SUCCESS;
try
-gfc_check_flush (gfc_expr * unit)
+gfc_check_flush (gfc_expr *unit)
{
if (unit == NULL)
return SUCCESS;
try
-gfc_check_free (gfc_expr * i)
+gfc_check_free (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_hostnm (gfc_expr * name)
+gfc_check_hostnm (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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;
try
-gfc_check_itime_idate (gfc_expr * values)
+gfc_check_itime_idate (gfc_expr *values)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
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;
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;
try
-gfc_check_isatty (gfc_expr * unit)
+gfc_check_isatty (gfc_expr *unit)
{
if (unit == NULL)
return FAILURE;
try
-gfc_check_perror (gfc_expr * string)
+gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_umask (gfc_expr * mask)
+gfc_check_umask (gfc_expr *mask)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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;
try
-gfc_check_unlink (gfc_expr * name)
+gfc_check_unlink (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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;
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;
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;
}
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;
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;
}
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;
/* 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;
}
projects / platform / upstream / linaro-gcc.git / commitdiff