| /* Check functions |
| Copyright (C) 2002-2019 Free Software Foundation, Inc. |
| Contributed by Andy Vaught & Katherine Holcomb |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| |
| /* These functions check to see if an argument list is compatible with |
| a particular intrinsic function or subroutine. Presence of |
| required arguments has already been established, the argument list |
| has been sorted into the right order and has NULL arguments in the |
| correct places for missing optional arguments. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "gfortran.h" |
| #include "intrinsic.h" |
| #include "constructor.h" |
| #include "target-memory.h" |
| |
| |
| /* Make sure an expression is a scalar. */ |
| |
| static bool |
| scalar_check (gfc_expr *e, int n) |
| { |
| if (e->rank == 0) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where); |
| |
| return false; |
| } |
| |
| |
| /* Check the type of an expression. */ |
| |
| static bool |
| type_check (gfc_expr *e, int n, bt type) |
| { |
| if (e->ts.type == type) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be %s", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where, gfc_basic_typename (type)); |
| |
| return false; |
| } |
| |
| |
| /* Check that the expression is a numeric type. */ |
| |
| static bool |
| numeric_check (gfc_expr *e, int n) |
| { |
| /* Users sometime use a subroutine designator as an actual argument to |
| an intrinsic subprogram that expects an argument with a numeric type. */ |
| if (e->symtree && e->symtree->n.sym->attr.subroutine) |
| goto error; |
| |
| if (gfc_numeric_ts (&e->ts)) |
| return true; |
| |
| /* If the expression has not got a type, check if its namespace can |
| offer a default type. */ |
| if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) |
| && e->symtree->n.sym->ts.type == BT_UNKNOWN |
| && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) |
| && gfc_numeric_ts (&e->symtree->n.sym->ts)) |
| { |
| e->ts = e->symtree->n.sym->ts; |
| return true; |
| } |
| |
| error: |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where); |
| |
| return false; |
| } |
| |
| |
| /* Check that an expression is integer or real. */ |
| |
| static bool |
| int_or_real_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or REAL", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| /* Check that an expression is integer or real; allow character for |
| F2003 or later. */ |
| |
| static bool |
| int_or_real_or_char_check_f2003 (gfc_expr *e, int n) |
| { |
| if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) |
| { |
| if (e->ts.type == BT_CHARACTER) |
| return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for " |
| "%qs argument of %qs intrinsic at %L", |
| gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| else |
| { |
| if (gfc_option.allow_std & GFC_STD_F2003) |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or REAL or CHARACTER", |
| gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| else |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or REAL", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| } |
| return false; |
| } |
| |
| return true; |
| } |
| |
| /* Check that an expression is an intrinsic type. */ |
| static bool |
| intrinsic_type_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL |
| && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER |
| && e->ts.type != BT_LOGICAL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type", |
| gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| return true; |
| } |
| |
| /* Check that an expression is real or complex. */ |
| |
| static bool |
| real_or_complex_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " |
| "or COMPLEX", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Check that an expression is INTEGER or PROCEDURE. */ |
| |
| static bool |
| int_or_proc_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Check that the expression is an optional constant integer |
| and that it specifies a valid kind for that type. */ |
| |
| static bool |
| kind_check (gfc_expr *k, int n, bt type) |
| { |
| int kind; |
| |
| if (k == NULL) |
| return true; |
| |
| if (!type_check (k, n, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (k, n)) |
| return false; |
| |
| if (!gfc_check_init_expr (k)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &k->where); |
| return false; |
| } |
| |
| if (gfc_extract_int (k, &kind) |
| || gfc_validate_kind (type, kind, true) < 0) |
| { |
| gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), |
| &k->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Make sure the expression is a double precision real. */ |
| |
| static bool |
| double_check (gfc_expr *d, int n) |
| { |
| if (!type_check (d, n, BT_REAL)) |
| return false; |
| |
| if (d->ts.kind != gfc_default_double_kind) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be double " |
| "precision", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &d->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| static bool |
| coarray_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok |
| && CLASS_DATA (e)->attr.codimension |
| && CLASS_DATA (e)->as->corank) |
| { |
| gfc_add_class_array_ref (e); |
| return true; |
| } |
| |
| if (!gfc_is_coarray (e)) |
| { |
| gfc_error ("Expected coarray variable as %qs argument to the %s " |
| "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Make sure the expression is a logical array. */ |
| |
| static bool |
| logical_array_check (gfc_expr *array, int n) |
| { |
| if (array->ts.type != BT_LOGICAL || array->rank == 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " |
| "array", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &array->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Make sure an expression is an array. */ |
| |
| static bool |
| array_check (gfc_expr *e, int n) |
| { |
| if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok |
| && CLASS_DATA (e)->attr.dimension |
| && CLASS_DATA (e)->as->rank) |
| { |
| gfc_add_class_array_ref (e); |
| return true; |
| } |
| |
| if (e->rank != 0 && e->ts.type != BT_PROCEDURE) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be an array", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where); |
| |
| return false; |
| } |
| |
| |
| /* If expr is a constant, then check to ensure that it is greater than |
| of equal to zero. */ |
| |
| static bool |
| nonnegative_check (const char *arg, gfc_expr *expr) |
| { |
| int i; |
| |
| if (expr->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (expr, &i); |
| if (i < 0) |
| { |
| gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* If expr is a constant, then check to ensure that it is greater than zero. */ |
| |
| static bool |
| positive_check (int n, gfc_expr *expr) |
| { |
| int i; |
| |
| if (expr->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (expr, &i); |
| if (i <= 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be positive", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &expr->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* If expr2 is constant, then check that the value is less than |
| (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ |
| |
| static bool |
| less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, |
| gfc_expr *expr2, bool or_equal) |
| { |
| int i2, i3; |
| |
| if (expr2->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (expr2, &i2); |
| i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); |
| |
| /* For ISHFT[C], check that |shift| <= bit_size(i). */ |
| if (arg2 == NULL) |
| { |
| if (i2 < 0) |
| i2 = -i2; |
| |
| if (i2 > gfc_integer_kinds[i3].bit_size) |
| { |
| gfc_error ("The absolute value of SHIFT at %L must be less " |
| "than or equal to BIT_SIZE(%qs)", |
| &expr2->where, arg1); |
| return false; |
| } |
| } |
| |
| if (or_equal) |
| { |
| if (i2 > gfc_integer_kinds[i3].bit_size) |
| { |
| gfc_error ("%qs at %L must be less than " |
| "or equal to BIT_SIZE(%qs)", |
| arg2, &expr2->where, arg1); |
| return false; |
| } |
| } |
| else |
| { |
| if (i2 >= gfc_integer_kinds[i3].bit_size) |
| { |
| gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", |
| arg2, &expr2->where, arg1); |
| return false; |
| } |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* If expr is constant, then check that the value is less than or equal |
| to the bit_size of the kind k. */ |
| |
| static bool |
| less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) |
| { |
| int i, val; |
| |
| if (expr->expr_type != EXPR_CONSTANT) |
| return true; |
| |
| i = gfc_validate_kind (BT_INTEGER, k, false); |
| gfc_extract_int (expr, &val); |
| |
| if (val > gfc_integer_kinds[i].bit_size) |
| { |
| gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " |
| "INTEGER(KIND=%d)", arg, &expr->where, k); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* If expr2 and expr3 are constants, then check that the value is less than |
| or equal to bit_size(expr1). */ |
| |
| static bool |
| less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, |
| gfc_expr *expr2, const char *arg3, gfc_expr *expr3) |
| { |
| int i2, i3; |
| |
| if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (expr2, &i2); |
| gfc_extract_int (expr3, &i3); |
| i2 += i3; |
| i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); |
| if (i2 > gfc_integer_kinds[i3].bit_size) |
| { |
| gfc_error ("%<%s + %s%> at %L must be less than or equal " |
| "to BIT_SIZE(%qs)", |
| arg2, arg3, &expr2->where, arg1); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| /* Make sure two expressions have the same type. */ |
| |
| static bool |
| same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false) |
| { |
| gfc_typespec *ets = &e->ts; |
| gfc_typespec *fts = &f->ts; |
| |
| if (assoc) |
| { |
| /* Procedure pointer component expressions have the type of the interface |
| procedure. If they are being tested for association with a procedure |
| pointer (ie. not a component), the type of the procedure must be |
| determined. */ |
| if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) |
| ets = &e->symtree->n.sym->ts; |
| if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) |
| fts = &f->symtree->n.sym->ts; |
| } |
| |
| if (gfc_compare_types (ets, fts)) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " |
| "and kind as %qs", gfc_current_intrinsic_arg[m]->name, |
| gfc_current_intrinsic, &f->where, |
| gfc_current_intrinsic_arg[n]->name); |
| |
| return false; |
| } |
| |
| |
| /* Make sure that an expression has a certain (nonzero) rank. */ |
| |
| static bool |
| rank_check (gfc_expr *e, int n, int rank) |
| { |
| if (e->rank == rank) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where, rank); |
| |
| return false; |
| } |
| |
| |
| /* Make sure a variable expression is not an optional dummy argument. */ |
| |
| static bool |
| nonoptional_check (gfc_expr *e, int n) |
| { |
| if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where); |
| } |
| |
| /* TODO: Recursive check on nonoptional variables? */ |
| |
| return true; |
| } |
| |
| |
| /* Check for ALLOCATABLE attribute. */ |
| |
| static bool |
| allocatable_check (gfc_expr *e, int n) |
| { |
| symbol_attribute attr; |
| |
| attr = gfc_variable_attr (e, NULL); |
| if (!attr.allocatable || attr.associate_var) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Check that an expression has a particular kind. */ |
| |
| static bool |
| kind_value_check (gfc_expr *e, int n, int k) |
| { |
| if (e->ts.kind == k) |
| return true; |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, |
| &e->where, k); |
| |
| return false; |
| } |
| |
| |
| /* Make sure an expression is a variable. */ |
| |
| static bool |
| variable_check (gfc_expr *e, int n, bool allow_proc) |
| { |
| if (e->expr_type == EXPR_VARIABLE |
| && e->symtree->n.sym->attr.intent == INTENT_IN |
| && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT |
| || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)) |
| { |
| gfc_ref *ref; |
| bool pointer = e->symtree->n.sym->ts.type == BT_CLASS |
| && CLASS_DATA (e->symtree->n.sym) |
| ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer |
| : e->symtree->n.sym->attr.pointer; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (pointer && ref->type == REF_COMPONENT) |
| break; |
| if (ref->type == REF_COMPONENT |
| && ((ref->u.c.component->ts.type == BT_CLASS |
| && CLASS_DATA (ref->u.c.component)->attr.class_pointer) |
| || (ref->u.c.component->ts.type != BT_CLASS |
| && ref->u.c.component->attr.pointer))) |
| break; |
| } |
| |
| if (!ref) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L cannot be " |
| "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, |
| gfc_current_intrinsic, &e->where); |
| return false; |
| } |
| } |
| |
| if (e->expr_type == EXPR_VARIABLE |
| && e->symtree->n.sym->attr.flavor != FL_PARAMETER |
| && (allow_proc || !e->symtree->n.sym->attr.function)) |
| return true; |
| |
| if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function |
| && e->symtree->n.sym == e->symtree->n.sym->result) |
| { |
| gfc_namespace *ns; |
| for (ns = gfc_current_ns; ns; ns = ns->parent) |
| if (ns->proc_name == e->symtree->n.sym) |
| return true; |
| } |
| |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", |
| gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); |
| |
| return false; |
| } |
| |
| |
| /* Check the common DIM parameter for correctness. */ |
| |
| static bool |
| dim_check (gfc_expr *dim, int n, bool optional) |
| { |
| if (dim == NULL) |
| return true; |
| |
| if (!type_check (dim, n, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (dim, n)) |
| return false; |
| |
| if (!optional && !nonoptional_check (dim, n)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* If a coarray DIM parameter is a constant, make sure that it is greater than |
| zero and less than or equal to the corank of the given array. */ |
| |
| static bool |
| dim_corank_check (gfc_expr *dim, gfc_expr *array) |
| { |
| int corank; |
| |
| gcc_assert (array->expr_type == EXPR_VARIABLE); |
| |
| if (dim->expr_type != EXPR_CONSTANT) |
| return true; |
| |
| if (array->ts.type == BT_CLASS) |
| return true; |
| |
| corank = gfc_get_corank (array); |
| |
| if (mpz_cmp_ui (dim->value.integer, 1) < 0 |
| || mpz_cmp_ui (dim->value.integer, corank) > 0) |
| { |
| gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " |
| "codimension index", gfc_current_intrinsic, &dim->where); |
| |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* If a DIM parameter is a constant, make sure that it is greater than |
| zero and less than or equal to the rank of the given array. If |
| allow_assumed is zero then dim must be less than the rank of the array |
| for assumed size arrays. */ |
| |
| static bool |
| dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) |
| { |
| gfc_array_ref *ar; |
| int rank; |
| |
| if (dim == NULL) |
| return true; |
| |
| if (dim->expr_type != EXPR_CONSTANT) |
| return true; |
| |
| if (array->expr_type == EXPR_FUNCTION && array->value.function.isym |
| && array->value.function.isym->id == GFC_ISYM_SPREAD) |
| rank = array->rank + 1; |
| else |
| rank = array->rank; |
| |
| /* Assumed-rank array. */ |
| if (rank == -1) |
| rank = GFC_MAX_DIMENSIONS; |
| |
| if (array->expr_type == EXPR_VARIABLE) |
| { |
| ar = gfc_find_array_ref (array); |
| if (ar->as->type == AS_ASSUMED_SIZE |
| && !allow_assumed |
| && ar->type != AR_ELEMENT |
| && ar->type != AR_SECTION) |
| rank--; |
| } |
| |
| if (mpz_cmp_ui (dim->value.integer, 1) < 0 |
| || mpz_cmp_ui (dim->value.integer, rank) > 0) |
| { |
| gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " |
| "dimension index", gfc_current_intrinsic, &dim->where); |
| |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* 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. */ |
| |
| static int |
| identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) |
| { |
| mpz_t a_size, b_size; |
| int ret; |
| |
| gcc_assert (a->rank > ai); |
| gcc_assert (b->rank > bi); |
| |
| ret = 1; |
| |
| if (gfc_array_dimen_size (a, ai, &a_size)) |
| { |
| if (gfc_array_dimen_size (b, bi, &b_size)) |
| { |
| if (mpz_cmp (a_size, b_size) != 0) |
| ret = 0; |
| |
| mpz_clear (b_size); |
| } |
| mpz_clear (a_size); |
| } |
| return ret; |
| } |
| |
| /* Calculate the length of a character variable, including substrings. |
| Strip away parentheses if necessary. Return -1 if no length could |
| be determined. */ |
| |
| static long |
| gfc_var_strlen (const gfc_expr *a) |
| { |
| gfc_ref *ra; |
| |
| while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) |
| a = a->value.op.op1; |
| |
| for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) |
| ; |
| |
| if (ra) |
| { |
| long start_a, end_a; |
| |
| if (!ra->u.ss.end) |
| return -1; |
| |
| if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT) |
| && ra->u.ss.end->expr_type == EXPR_CONSTANT) |
| { |
| start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer) |
| : 1; |
| end_a = mpz_get_si (ra->u.ss.end->value.integer); |
| return (end_a < start_a) ? 0 : end_a - start_a + 1; |
| } |
| else if (ra->u.ss.start |
| && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) |
| return 1; |
| else |
| return -1; |
| } |
| |
| if (a->ts.u.cl && a->ts.u.cl->length |
| && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| return mpz_get_si (a->ts.u.cl->length->value.integer); |
| else if (a->expr_type == EXPR_CONSTANT |
| && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) |
| return a->value.character.length; |
| else |
| return -1; |
| |
| } |
| |
| /* Check whether two character expressions have the same length; |
| returns true if they have or if the length cannot be determined, |
| otherwise return false and raise a gfc_error. */ |
| |
| bool |
| gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) |
| { |
| long len_a, len_b; |
| |
| len_a = gfc_var_strlen(a); |
| len_b = gfc_var_strlen(b); |
| |
| if (len_a == -1 || len_b == -1 || len_a == len_b) |
| return true; |
| else |
| { |
| gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", |
| len_a, len_b, name, &a->where); |
| return false; |
| } |
| } |
| |
| |
| /***** Check functions *****/ |
| |
| /* Check subroutine suitable for intrinsics taking a real argument and |
| a kind argument for the result. */ |
| |
| static bool |
| check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) |
| { |
| if (!type_check (a, 0, BT_REAL)) |
| return false; |
| if (!kind_check (kind, 1, type)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Check subroutine suitable for ceiling, floor and nint. */ |
| |
| bool |
| gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) |
| { |
| return check_a_kind (a, kind, BT_INTEGER); |
| } |
| |
| |
| /* Check subroutine suitable for aint, anint. */ |
| |
| bool |
| gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) |
| { |
| return check_a_kind (a, kind, BT_REAL); |
| } |
| |
| |
| bool |
| gfc_check_abs (gfc_expr *a) |
| { |
| if (!numeric_check (a, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_achar (gfc_expr *a, gfc_expr *kind) |
| { |
| if (!type_check (a, 0, BT_INTEGER)) |
| return false; |
| if (!kind_check (kind, 1, BT_CHARACTER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_access_func (gfc_expr *name, gfc_expr *mode) |
| { |
| if (!type_check (name, 0, BT_CHARACTER) |
| || !scalar_check (name, 0)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (mode, 1, BT_CHARACTER) |
| || !scalar_check (mode, 1)) |
| return false; |
| if (!kind_value_check (mode, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) |
| { |
| if (!logical_array_check (mask, 0)) |
| return false; |
| |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_rank_check (dim, mask, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_allocated (gfc_expr *array) |
| { |
| /* Tests on allocated components of coarrays need to detour the check to |
| argument of the _caf_get. */ |
| if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION |
| && array->value.function.isym |
| && array->value.function.isym->id == GFC_ISYM_CAF_GET) |
| { |
| array = array->value.function.actual->expr; |
| if (!array->ref) |
| return false; |
| } |
| |
| if (!variable_check (array, 0, false)) |
| return false; |
| if (!allocatable_check (array, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Common check function where the first argument must be real or |
| integer and the second argument must be the same as the first. */ |
| |
| bool |
| gfc_check_a_p (gfc_expr *a, gfc_expr *p) |
| { |
| if (!int_or_real_check (a, 0)) |
| return false; |
| |
| if (a->ts.type != p->ts.type) |
| { |
| gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " |
| "have the same type", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &p->where); |
| return false; |
| } |
| |
| if (a->ts.kind != p->ts.kind) |
| { |
| if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", |
| &p->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_x_yd (gfc_expr *x, gfc_expr *y) |
| { |
| if (!double_check (x, 0) || !double_check (y, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_associated (gfc_expr *pointer, gfc_expr *target) |
| { |
| symbol_attribute attr1, attr2; |
| int i; |
| bool t; |
| locus *where; |
| |
| where = &pointer->where; |
| |
| if (pointer->expr_type == EXPR_NULL) |
| goto null_arg; |
| |
| attr1 = gfc_expr_attr (pointer); |
| |
| if (!attr1.pointer && !attr1.proc_pointer) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &pointer->where); |
| return false; |
| } |
| |
| /* F2008, C1242. */ |
| if (attr1.pointer && gfc_is_coindexed (pointer)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be " |
| "coindexed", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &pointer->where); |
| return false; |
| } |
| |
| /* Target argument is optional. */ |
| if (target == NULL) |
| return true; |
| |
| where = &target->where; |
| if (target->expr_type == EXPR_NULL) |
| goto null_arg; |
| |
| if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) |
| attr2 = gfc_expr_attr (target); |
| else |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " |
| "or target VARIABLE or FUNCTION", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &target->where); |
| return false; |
| } |
| |
| if (attr1.pointer && !attr2.pointer && !attr2.target) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " |
| "or a TARGET", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &target->where); |
| return false; |
| } |
| |
| /* F2008, C1242. */ |
| if (attr1.pointer && gfc_is_coindexed (target)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be " |
| "coindexed", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &target->where); |
| return false; |
| } |
| |
| t = true; |
| if (!same_type_check (pointer, 0, target, 1, true)) |
| t = false; |
| if (!rank_check (target, 0, pointer->rank)) |
| t = false; |
| 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 " |
| "be the target of a pointer", |
| &target->where); |
| t = false; |
| break; |
| } |
| } |
| return t; |
| |
| null_arg: |
| |
| gfc_error ("NULL pointer at %L is not permitted as actual argument " |
| "of %qs intrinsic function", where, gfc_current_intrinsic); |
| return false; |
| |
| } |
| |
| |
| bool |
| gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) |
| { |
| /* gfc_notify_std would be a waste of time as the return value |
| is seemingly used only for the generic resolution. The error |
| will be: Too many arguments. */ |
| if ((gfc_option.allow_std & GFC_STD_F2008) == 0) |
| return false; |
| |
| return gfc_check_atan2 (y, x); |
| } |
| |
| |
| bool |
| gfc_check_atan2 (gfc_expr *y, gfc_expr *x) |
| { |
| if (!type_check (y, 0, BT_REAL)) |
| return false; |
| if (!same_type_check (y, 0, x, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| static bool |
| gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, |
| gfc_expr *stat, int stat_no) |
| { |
| if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) |
| return false; |
| |
| if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) |
| && !(atom->ts.type == BT_LOGICAL |
| && atom->ts.kind == gfc_atomic_logical_kind)) |
| { |
| gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " |
| "integer of ATOMIC_INT_KIND or a logical of " |
| "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic); |
| return false; |
| } |
| |
| if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom)) |
| { |
| gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " |
| "coarray or coindexed", &atom->where, gfc_current_intrinsic); |
| return false; |
| } |
| |
| if (atom->ts.type != value->ts.type) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall have the same " |
| "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name, |
| gfc_current_intrinsic, &value->where, |
| gfc_current_intrinsic_arg[atom_no]->name, &atom->where); |
| return false; |
| } |
| |
| if (stat != NULL) |
| { |
| if (!type_check (stat, stat_no, BT_INTEGER)) |
| return false; |
| if (!scalar_check (stat, stat_no)) |
| return false; |
| if (!variable_check (stat, stat_no, false)) |
| return false; |
| if (!kind_value_check (stat, stat_no, gfc_default_integer_kind)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", |
| gfc_current_intrinsic, &stat->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) |
| { |
| if (atom->expr_type == EXPR_FUNCTION |
| && atom->value.function.isym |
| && atom->value.function.isym->id == GFC_ISYM_CAF_GET) |
| atom = atom->value.function.actual->expr; |
| |
| if (!gfc_check_vardef_context (atom, false, false, false, NULL)) |
| { |
| gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &atom->where); |
| return false; |
| } |
| |
| return gfc_check_atomic (atom, 0, value, 1, stat, 2); |
| } |
| |
| |
| bool |
| gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) |
| { |
| if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) |
| { |
| gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " |
| "integer of ATOMIC_INT_KIND", &atom->where, |
| gfc_current_intrinsic); |
| return false; |
| } |
| |
| return gfc_check_atomic_def (atom, value, stat); |
| } |
| |
| |
| bool |
| gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) |
| { |
| if (atom->expr_type == EXPR_FUNCTION |
| && atom->value.function.isym |
| && atom->value.function.isym->id == GFC_ISYM_CAF_GET) |
| atom = atom->value.function.actual->expr; |
| |
| if (!gfc_check_vardef_context (value, false, false, false, NULL)) |
| { |
| gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &value->where); |
| return false; |
| } |
| |
| return gfc_check_atomic (atom, 1, value, 0, stat, 2); |
| } |
| |
| |
| bool |
| gfc_check_image_status (gfc_expr *image, gfc_expr *team) |
| { |
| /* IMAGE has to be a positive, scalar integer. */ |
| if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0) |
| || !positive_check (0, image)) |
| return false; |
| |
| if (team) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &team->where); |
| return false; |
| } |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) |
| { |
| if (team) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &team->where); |
| return false; |
| } |
| |
| if (kind) |
| { |
| int k; |
| |
| if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1) |
| || !positive_check (1, kind)) |
| return false; |
| |
| /* Get the kind, reporting error on non-constant or overflow. */ |
| gfc_current_locus = kind->where; |
| if (gfc_extract_int (kind, &k, 1)) |
| return false; |
| if (gfc_validate_kind (BT_INTEGER, k, true) == -1) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall specify a " |
| "valid integer kind", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &kind->where); |
| return false; |
| } |
| } |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_get_team (gfc_expr *level) |
| { |
| if (level) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &level->where); |
| return false; |
| } |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, |
| gfc_expr *new_val, gfc_expr *stat) |
| { |
| if (atom->expr_type == EXPR_FUNCTION |
| && atom->value.function.isym |
| && atom->value.function.isym->id == GFC_ISYM_CAF_GET) |
| atom = atom->value.function.actual->expr; |
| |
| if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4)) |
| return false; |
| |
| if (!scalar_check (old, 1) || !scalar_check (compare, 2)) |
| return false; |
| |
| if (!same_type_check (atom, 0, old, 1)) |
| return false; |
| |
| if (!same_type_check (atom, 0, compare, 2)) |
| return false; |
| |
| if (!gfc_check_vardef_context (atom, false, false, false, NULL)) |
| { |
| gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &atom->where); |
| return false; |
| } |
| |
| if (!gfc_check_vardef_context (old, false, false, false, NULL)) |
| { |
| gfc_error ("OLD argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &old->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat) |
| { |
| if (event->ts.type != BT_DERIVED |
| || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV |
| || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE) |
| { |
| gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY " |
| "shall be of type EVENT_TYPE", &event->where); |
| return false; |
| } |
| |
| if (!scalar_check (event, 0)) |
| return false; |
| |
| if (!gfc_check_vardef_context (count, false, false, false, NULL)) |
| { |
| gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " |
| "shall be definable", &count->where); |
| return false; |
| } |
| |
| if (!type_check (count, 1, BT_INTEGER)) |
| return false; |
| |
| int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false); |
| int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); |
| |
| if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) |
| { |
| gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " |
| "shall have at least the range of the default integer", |
| &count->where); |
| return false; |
| } |
| |
| if (stat != NULL) |
| { |
| if (!type_check (stat, 2, BT_INTEGER)) |
| return false; |
| if (!scalar_check (stat, 2)) |
| return false; |
| if (!variable_check (stat, 2, false)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", |
| gfc_current_intrinsic, &stat->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, |
| gfc_expr *stat) |
| { |
| if (atom->expr_type == EXPR_FUNCTION |
| && atom->value.function.isym |
| && atom->value.function.isym->id == GFC_ISYM_CAF_GET) |
| atom = atom->value.function.actual->expr; |
| |
| if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) |
| { |
| gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " |
| "integer of ATOMIC_INT_KIND", &atom->where, |
| gfc_current_intrinsic); |
| return false; |
| } |
| |
| if (!gfc_check_atomic (atom, 0, value, 1, stat, 3)) |
| return false; |
| |
| if (!scalar_check (old, 2)) |
| return false; |
| |
| if (!same_type_check (atom, 0, old, 2)) |
| return false; |
| |
| if (!gfc_check_vardef_context (atom, false, false, false, NULL)) |
| { |
| gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &atom->where); |
| return false; |
| } |
| |
| if (!gfc_check_vardef_context (old, false, false, false, NULL)) |
| { |
| gfc_error ("OLD argument of the %s intrinsic function at %L shall be " |
| "definable", gfc_current_intrinsic, &old->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* BESJN and BESYN functions. */ |
| |
| bool |
| gfc_check_besn (gfc_expr *n, gfc_expr *x) |
| { |
| if (!type_check (n, 0, BT_INTEGER)) |
| return false; |
| if (n->expr_type == EXPR_CONSTANT) |
| { |
| int i; |
| gfc_extract_int (n, &i); |
| if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " |
| "N at %L", &n->where)) |
| return false; |
| } |
| |
| if (!type_check (x, 1, BT_REAL)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Transformational version of the Bessel JN and YN functions. */ |
| |
| bool |
| gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) |
| { |
| if (!type_check (n1, 0, BT_INTEGER)) |
| return false; |
| if (!scalar_check (n1, 0)) |
| return false; |
| if (!nonnegative_check ("N1", n1)) |
| return false; |
| |
| if (!type_check (n2, 1, BT_INTEGER)) |
| return false; |
| if (!scalar_check (n2, 1)) |
| return false; |
| if (!nonnegative_check ("N2", n2)) |
| return false; |
| |
| if (!type_check (x, 2, BT_REAL)) |
| return false; |
| if (!scalar_check (x, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (j, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (pos, 1, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("pos", pos)) |
| return false; |
| |
| if (!less_than_bitsize1 ("i", i, "pos", pos, false)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_char (gfc_expr *i, gfc_expr *kind) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| if (!kind_check (kind, 1, BT_CHARACTER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_chdir (gfc_expr *dir) |
| { |
| if (!type_check (dir, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (dir, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) |
| { |
| if (!type_check (dir, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (dir, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 1, BT_INTEGER)) |
| return false; |
| if (!scalar_check (status, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_chmod (gfc_expr *name, gfc_expr *mode) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (mode, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (mode, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (mode, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (mode, 1, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| if (y != NULL) |
| { |
| if (!numeric_check (y, 1)) |
| return false; |
| |
| if (x->ts.type == BT_COMPLEX) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must not be " |
| "present if %<x%> is COMPLEX", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &y->where); |
| return false; |
| } |
| |
| if (y->ts.type == BT_COMPLEX) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must have a type " |
| "of either REAL or INTEGER", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &y->where); |
| return false; |
| } |
| |
| } |
| |
| if (!kind_check (kind, 2, BT_COMPLEX)) |
| return false; |
| |
| if (!kind && warn_conversion |
| && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) |
| gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " |
| "COMPLEX(%d) at %L might lose precision, consider using " |
| "the KIND argument", gfc_typename (&x->ts), |
| gfc_default_real_kind, &x->where); |
| else if (y && !kind && warn_conversion |
| && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) |
| gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " |
| "COMPLEX(%d) at %L might lose precision, consider using " |
| "the KIND argument", gfc_typename (&y->ts), |
| gfc_default_real_kind, &y->where); |
| return true; |
| } |
| |
| |
| static bool |
| check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, |
| gfc_expr *errmsg, bool co_reduce) |
| { |
| if (!variable_check (a, 0, false)) |
| return false; |
| |
| if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with " |
| "INTENT(INOUT)")) |
| return false; |
| |
| /* Fortran 2008, 12.5.2.4, paragraph 18. */ |
| if (gfc_has_vector_subscript (a)) |
| { |
| gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic " |
| "subroutine %s shall not have a vector subscript", |
| &a->where, gfc_current_intrinsic); |
| return false; |
| } |
| |
| if (gfc_is_coindexed (a)) |
| { |
| gfc_error ("The A argument at %L to the intrinsic %s shall not be " |
| "coindexed", &a->where, gfc_current_intrinsic); |
| return false; |
| } |
| |
| if (image_idx != NULL) |
| { |
| if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) |
| return false; |
| if (!scalar_check (image_idx, co_reduce ? 2 : 1)) |
| return false; |
| } |
| |
| if (stat != NULL) |
| { |
| if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) |
| return false; |
| if (!scalar_check (stat, co_reduce ? 3 : 2)) |
| return false; |
| if (!variable_check (stat, co_reduce ? 3 : 2, false)) |
| return false; |
| if (stat->ts.kind != 4) |
| { |
| gfc_error ("The stat= argument at %L must be a kind=4 integer " |
| "variable", &stat->where); |
| return false; |
| } |
| } |
| |
| if (errmsg != NULL) |
| { |
| if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) |
| return false; |
| if (!scalar_check (errmsg, co_reduce ? 4 : 3)) |
| return false; |
| if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) |
| return false; |
| if (errmsg->ts.kind != 1) |
| { |
| gfc_error ("The errmsg= argument at %L must be a default-kind " |
| "character variable", &errmsg->where); |
| return false; |
| } |
| } |
| |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", |
| &a->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, |
| gfc_expr *errmsg) |
| { |
| if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) |
| { |
| gfc_error ("Support for the A argument at %L which is polymorphic A " |
| "argument or has allocatable components is not yet " |
| "implemented", &a->where); |
| return false; |
| } |
| return check_co_collective (a, source_image, stat, errmsg, false); |
| } |
| |
| |
| bool |
| gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, |
| gfc_expr *stat, gfc_expr *errmsg) |
| { |
| symbol_attribute attr; |
| gfc_formal_arglist *formal; |
| gfc_symbol *sym; |
| |
| if (a->ts.type == BT_CLASS) |
| { |
| gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", |
| &a->where); |
| return false; |
| } |
| |
| if (gfc_expr_attr (a).alloc_comp) |
| { |
| gfc_error ("Support for the A argument at %L with allocatable components" |
| " is not yet implemented", &a->where); |
| return false; |
| } |
| |
| if (!check_co_collective (a, result_image, stat, errmsg, true)) |
| return false; |
| |
| if (!gfc_resolve_expr (op)) |
| return false; |
| |
| attr = gfc_expr_attr (op); |
| if (!attr.pure || !attr.function) |
| { |
| gfc_error ("OPERATOR argument at %L must be a PURE function", |
| &op->where); |
| return false; |
| } |
| |
| if (attr.intrinsic) |
| { |
| /* None of the intrinsics fulfills the criteria of taking two arguments, |
| returning the same type and kind as the arguments and being permitted |
| as actual argument. */ |
| gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE", |
| op->symtree->n.sym->name, &op->where); |
| return false; |
| } |
| |
| if (gfc_is_proc_ptr_comp (op)) |
| { |
| gfc_component *comp = gfc_get_proc_ptr_comp (op); |
| sym = comp->ts.interface; |
| } |
| else |
| sym = op->symtree->n.sym; |
| |
| formal = sym->formal; |
| |
| if (!formal || !formal->next || formal->next->next) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall have two " |
| "arguments", &op->where); |
| return false; |
| } |
| |
| if (sym->result->ts.type == BT_UNKNOWN) |
| gfc_set_default_type (sym->result, 0, NULL); |
| |
| if (!gfc_compare_types (&a->ts, &sym->result->ts)) |
| { |
| gfc_error ("The A argument at %L has type %s but the function passed as " |
| "OPERATOR at %L returns %s", |
| &a->where, gfc_typename (&a->ts), &op->where, |
| gfc_typename (&sym->result->ts)); |
| return false; |
| } |
| if (!gfc_compare_types (&a->ts, &formal->sym->ts) |
| || !gfc_compare_types (&a->ts, &formal->next->sym->ts)) |
| { |
| gfc_error ("The function passed as OPERATOR at %L has arguments of type " |
| "%s and %s but shall have type %s", &op->where, |
| gfc_typename (&formal->sym->ts), |
| gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts)); |
| return false; |
| } |
| if (op->rank || attr.allocatable || attr.pointer || formal->sym->as |
| || formal->next->sym->as || formal->sym->attr.allocatable |
| || formal->next->sym->attr.allocatable || formal->sym->attr.pointer |
| || formal->next->sym->attr.pointer) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall have scalar " |
| "nonallocatable nonpointer arguments and return a " |
| "nonallocatable nonpointer scalar", &op->where); |
| return false; |
| } |
| |
| if (formal->sym->attr.value != formal->next->sym->attr.value) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall have the VALUE " |
| "attribute either for none or both arguments", &op->where); |
| return false; |
| } |
| |
| if (formal->sym->attr.target != formal->next->sym->attr.target) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall have the TARGET " |
| "attribute either for none or both arguments", &op->where); |
| return false; |
| } |
| |
| if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall have the " |
| "ASYNCHRONOUS attribute either for none or both arguments", |
| &op->where); |
| return false; |
| } |
| |
| if (formal->sym->attr.optional || formal->next->sym->attr.optional) |
| { |
| gfc_error ("The function passed as OPERATOR at %L shall not have the " |
| "OPTIONAL attribute for either of the arguments", &op->where); |
| return false; |
| } |
| |
| if (a->ts.type == BT_CHARACTER) |
| { |
| gfc_charlen *cl; |
| unsigned long actual_size, formal_size1, formal_size2, result_size; |
| |
| cl = a->ts.u.cl; |
| actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT |
| ? mpz_get_ui (cl->length->value.integer) : 0; |
| |
| cl = formal->sym->ts.u.cl; |
| formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT |
| ? mpz_get_ui (cl->length->value.integer) : 0; |
| |
| cl = formal->next->sym->ts.u.cl; |
| formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT |
| ? mpz_get_ui (cl->length->value.integer) : 0; |
| |
| cl = sym->ts.u.cl; |
| result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT |
| ? mpz_get_ui (cl->length->value.integer) : 0; |
| |
| if (actual_size |
| && ((formal_size1 && actual_size != formal_size1) |
| || (formal_size2 && actual_size != formal_size2))) |
| { |
| gfc_error ("The character length of the A argument at %L and of the " |
| "arguments of the OPERATOR at %L shall be the same", |
| &a->where, &op->where); |
| return false; |
| } |
| if (actual_size && result_size && actual_size != result_size) |
| { |
| gfc_error ("The character length of the A argument at %L and of the " |
| "function result of the OPERATOR at %L shall be the same", |
| &a->where, &op->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, |
| gfc_expr *errmsg) |
| { |
| if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL |
| && a->ts.type != BT_CHARACTER) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " |
| "integer, real or character", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &a->where); |
| return false; |
| } |
| return check_co_collective (a, result_image, stat, errmsg, false); |
| } |
| |
| |
| bool |
| gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, |
| gfc_expr *errmsg) |
| { |
| if (!numeric_check (a, 0)) |
| return false; |
| return check_co_collective (a, result_image, stat, errmsg, false); |
| } |
| |
| |
| bool |
| gfc_check_complex (gfc_expr *x, gfc_expr *y) |
| { |
| if (!int_or_real_check (x, 0)) |
| return false; |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| if (!int_or_real_check (y, 1)) |
| return false; |
| if (!scalar_check (y, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (!logical_array_check (mask, 0)) |
| return false; |
| if (!dim_check (dim, 1, false)) |
| return false; |
| if (!dim_rank_check (dim, mask, 0)) |
| return false; |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!type_check (shift, 1, BT_INTEGER)) |
| return false; |
| |
| if (!dim_check (dim, 2, true)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, false)) |
| return false; |
| |
| if (array->rank == 1 || shift->rank == 0) |
| { |
| if (!scalar_check (shift, 1)) |
| return false; |
| } |
| else if (shift->rank == array->rank - 1) |
| { |
| int d; |
| if (!dim) |
| d = 1; |
| else if (dim->expr_type == EXPR_CONSTANT) |
| gfc_extract_int (dim, &d); |
| else |
| d = -1; |
| |
| if (d > 0) |
| { |
| int i, j; |
| for (i = 0, j = 0; i < array->rank; i++) |
| if (i != d - 1) |
| { |
| if (!identical_dimen_shape (array, i, shift, j)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L has " |
| "invalid shape in dimension %d (%ld/%ld)", |
| gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &shift->where, i + 1, |
| mpz_get_si (array->shape[i]), |
| mpz_get_si (shift->shape[j])); |
| return false; |
| } |
| |
| j += 1; |
| } |
| } |
| } |
| else |
| { |
| gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " |
| "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &shift->where, array->rank - 1); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ctime (gfc_expr *time) |
| { |
| if (!scalar_check (time, 0)) |
| return false; |
| |
| if (!type_check (time, 0, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) |
| { |
| if (!double_check (y, 0) || !double_check (x, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| if (y != NULL) |
| { |
| if (!numeric_check (y, 1)) |
| return false; |
| |
| if (x->ts.type == BT_COMPLEX) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must not be " |
| "present if %<x%> is COMPLEX", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &y->where); |
| return false; |
| } |
| |
| if (y->ts.type == BT_COMPLEX) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must have a type " |
| "of either REAL or INTEGER", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &y->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dble (gfc_expr *x) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_digits (gfc_expr *x) |
| { |
| if (!int_or_real_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) |
| { |
| switch (vector_a->ts.type) |
| { |
| case BT_LOGICAL: |
| if (!type_check (vector_b, 1, BT_LOGICAL)) |
| return false; |
| break; |
| |
| case BT_INTEGER: |
| case BT_REAL: |
| case BT_COMPLEX: |
| if (!numeric_check (vector_b, 1)) |
| return false; |
| break; |
| |
| default: |
| gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " |
| "or LOGICAL", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &vector_a->where); |
| return false; |
| } |
| |
| if (!rank_check (vector_a, 0, 1)) |
| return false; |
| |
| if (!rank_check (vector_b, 1, 1)) |
| return false; |
| |
| if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) |
| { |
| gfc_error ("Different shape for arguments %qs and %qs at %L for " |
| "intrinsic %<dot_product%>", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, &vector_a->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dprod (gfc_expr *x, gfc_expr *y) |
| { |
| if (!type_check (x, 0, BT_REAL) |
| || !type_check (y, 1, BT_REAL)) |
| return false; |
| |
| if (x->ts.kind != gfc_default_real_kind) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be default " |
| "real", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &x->where); |
| return false; |
| } |
| |
| if (y->ts.kind != gfc_default_real_kind) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be default " |
| "real", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &y->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| static bool |
| boz_args_check(gfc_expr *i, gfc_expr *j) |
| { |
| if (i->is_boz && j->is_boz) |
| { |
| gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " |
| "literal constants", gfc_current_intrinsic, &i->where, |
| &j->where); |
| return false; |
| |
| } |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (j, 1, BT_INTEGER)) |
| return false; |
| |
| if (!boz_args_check (i, j)) |
| return false; |
| |
| if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) |
| return false; |
| |
| if (!type_check (shift, 2, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("SHIFT", shift)) |
| return false; |
| |
| if (i->is_boz) |
| { |
| if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true)) |
| return false; |
| i->ts.kind = j->ts.kind; |
| } |
| else |
| { |
| if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) |
| return false; |
| j->ts.kind = i->ts.kind; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, |
| gfc_expr *dim) |
| { |
| int d; |
| |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!type_check (shift, 1, BT_INTEGER)) |
| return false; |
| |
| if (!dim_check (dim, 3, true)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, false)) |
| return false; |
| |
| if (!dim) |
| d = 1; |
| else if (dim->expr_type == EXPR_CONSTANT) |
| gfc_extract_int (dim, &d); |
| else |
| d = -1; |
| |
| if (array->rank == 1 || shift->rank == 0) |
| { |
| if (!scalar_check (shift, 1)) |
| return false; |
| } |
| else if (shift->rank == array->rank - 1) |
| { |
| if (d > 0) |
| { |
| int i, j; |
| for (i = 0, j = 0; i < array->rank; i++) |
| if (i != d - 1) |
| { |
| if (!identical_dimen_shape (array, i, shift, j)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L has " |
| "invalid shape in dimension %d (%ld/%ld)", |
| gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &shift->where, i + 1, |
| mpz_get_si (array->shape[i]), |
| mpz_get_si (shift->shape[j])); |
| return false; |
| } |
| |
| j += 1; |
| } |
| } |
| } |
| else |
| { |
| gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " |
| "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &shift->where, array->rank - 1); |
| return false; |
| } |
| |
| if (boundary != NULL) |
| { |
| if (!same_type_check (array, 0, boundary, 2)) |
| return false; |
| |
| /* Reject unequal string lengths and emit a better error message than |
| gfc_check_same_strlen would. */ |
| if (array->ts.type == BT_CHARACTER) |
| { |
| ssize_t len_a, len_b; |
| |
| len_a = gfc_var_strlen (array); |
| len_b = gfc_var_strlen (boundary); |
| if (len_a != -1 && len_b != -1 && len_a != len_b) |
| { |
| gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic_arg[0]->name, |
| &boundary->where, gfc_current_intrinsic); |
| return false; |
| } |
| } |
| |
| if (array->rank == 1 || boundary->rank == 0) |
| { |
| if (!scalar_check (boundary, 2)) |
| return false; |
| } |
| else if (boundary->rank == array->rank - 1) |
| { |
| if (d > 0) |
| { |
| int i,j; |
| for (i = 0, j = 0; i < array->rank; i++) |
| { |
| if (i != d - 1) |
| { |
| if (!identical_dimen_shape (array, i, boundary, j)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L has " |
| "invalid shape in dimension %d (%ld/%ld)", |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic, &shift->where, i+1, |
| mpz_get_si (array->shape[i]), |
| mpz_get_si (boundary->shape[j])); |
| return false; |
| } |
| j += 1; |
| } |
| } |
| } |
| } |
| else |
| { |
| gfc_error ("%qs argument of intrinsic %qs at %L of must have " |
| "rank %d or be a scalar", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &shift->where, array->rank - 1); |
| return false; |
| } |
| } |
| else |
| { |
| switch (array->ts.type) |
| { |
| case BT_INTEGER: |
| case BT_LOGICAL: |
| case BT_REAL: |
| case BT_COMPLEX: |
| case BT_CHARACTER: |
| break; |
| |
| default: |
| gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs " |
| "of type %qs", gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic, &array->where, |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_typename (&array->ts)); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_float (gfc_expr *a) |
| { |
| if (!type_check (a, 0, BT_INTEGER)) |
| return false; |
| |
| if ((a->ts.kind != gfc_default_integer_kind) |
| && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " |
| "kind argument to %s intrinsic at %L", |
| gfc_current_intrinsic, &a->where)) |
| return false; |
| |
| return true; |
| } |
| |
| /* A single complex argument. */ |
| |
| bool |
| gfc_check_fn_c (gfc_expr *a) |
| { |
| if (!type_check (a, 0, BT_COMPLEX)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* A single real argument. */ |
| |
| bool |
| gfc_check_fn_r (gfc_expr *a) |
| { |
| if (!type_check (a, 0, BT_REAL)) |
| return false; |
| |
| return true; |
| } |
| |
| /* A single double argument. */ |
| |
| bool |
| gfc_check_fn_d (gfc_expr *a) |
| { |
| if (!double_check (a, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| /* A single real or complex argument. */ |
| |
| bool |
| gfc_check_fn_rc (gfc_expr *a) |
| { |
| if (!real_or_complex_check (a, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fn_rc2008 (gfc_expr *a) |
| { |
| if (!real_or_complex_check (a, 0)) |
| return false; |
| |
| if (a->ts.type == BT_COMPLEX |
| && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs " |
| "of %qs intrinsic at %L", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &a->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fnum (gfc_expr *unit) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_huge (gfc_expr *x) |
| { |
| if (!int_or_real_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_hypot (gfc_expr *x, gfc_expr *y) |
| { |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| if (!same_type_check (x, 0, y, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Check that the single argument is an integer. */ |
| |
| bool |
| gfc_check_i (gfc_expr *i) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (j, 1, BT_INTEGER)) |
| return false; |
| |
| if (!boz_args_check (i, j)) |
| return false; |
| |
| if (i->is_boz) i->ts.kind = j->ts.kind; |
| if (j->is_boz) j->ts.kind = i->ts.kind; |
| |
| if (i->ts.kind != j->ts.kind) |
| { |
| gfc_error ("Arguments of %qs have different kind type parameters " |
| "at %L", gfc_current_intrinsic, &i->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (pos, 1, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (len, 2, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("pos", pos)) |
| return false; |
| |
| if (!nonnegative_check ("len", len)) |
| return false; |
| |
| if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) |
| { |
| int i; |
| |
| if (!type_check (c, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!kind_check (kind, 1, BT_INTEGER)) |
| return false; |
| |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) |
| { |
| gfc_expr *start; |
| gfc_expr *end; |
| gfc_ref *ref; |
| |
| /* Substring references don't have the charlength set. */ |
| ref = c->ref; |
| while (ref && ref->type != REF_SUBSTRING) |
| ref = ref->next; |
| |
| gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); |
| |
| if (!ref) |
| { |
| /* Check that the argument is length one. Non-constant lengths |
| can't be checked here, so assume they are ok. */ |
| if (c->ts.u.cl && c->ts.u.cl->length) |
| { |
| /* If we already have a length for this expression then use it. */ |
| if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
| return true; |
| i = mpz_get_si (c->ts.u.cl->length->value.integer); |
| } |
| else |
| return true; |
| } |
| else |
| { |
| start = ref->u.ss.start; |
| end = ref->u.ss.end; |
| |
| gcc_assert (start); |
| if (end == NULL || end->expr_type != EXPR_CONSTANT |
| || start->expr_type != EXPR_CONSTANT) |
| return true; |
| |
| i = mpz_get_si (end->value.integer) + 1 |
| - mpz_get_si (start->value.integer); |
| } |
| } |
| else |
| return true; |
| |
| if (i != 1) |
| { |
| gfc_error ("Argument of %s at %L must be of length one", |
| gfc_current_intrinsic, &c->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_idnint (gfc_expr *a) |
| { |
| if (!double_check (a, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, |
| gfc_expr *kind) |
| { |
| if (!type_check (string, 0, BT_CHARACTER) |
| || !type_check (substring, 1, BT_CHARACTER)) |
| return false; |
| |
| if (back != NULL && !type_check (back, 2, BT_LOGICAL)) |
| return false; |
| |
| if (!kind_check (kind, 3, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| if (string->ts.kind != substring->ts.kind) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be the same " |
| "kind as %qs", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &substring->where, |
| gfc_current_intrinsic_arg[0]->name); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_int (gfc_expr *x, gfc_expr *kind) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| if (!kind_check (kind, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_intconv (gfc_expr *x) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_ishft (gfc_expr *i, gfc_expr *shift) |
| { |
| if (!type_check (i, 0, BT_INTEGER) |
| || !type_check (shift, 1, BT_INTEGER)) |
| return false; |
| |
| if (!less_than_bitsize1 ("I", i, NULL, shift, true)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) |
| { |
| if (!type_check (i, 0, BT_INTEGER) |
| || !type_check (shift, 1, BT_INTEGER)) |
| return false; |
| |
| if (size != NULL) |
| { |
| int i2, i3; |
| |
| if (!type_check (size, 2, BT_INTEGER)) |
| return false; |
| |
| if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) |
| return false; |
| |
| if (size->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (size, &i3); |
| if (i3 <= 0) |
| { |
| gfc_error ("SIZE at %L must be positive", &size->where); |
| return false; |
| } |
| |
| if (shift->expr_type == EXPR_CONSTANT) |
| { |
| gfc_extract_int (shift, &i2); |
| if (i2 < 0) |
| i2 = -i2; |
| |
| if (i2 > i3) |
| { |
| gfc_error ("The absolute value of SHIFT at %L must be less " |
| "than or equal to SIZE at %L", &shift->where, |
| &size->where); |
| return false; |
| } |
| } |
| } |
| } |
| else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_kill (gfc_expr *pid, gfc_expr *sig) |
| { |
| if (!type_check (pid, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (pid, 0)) |
| return false; |
| |
| if (!type_check (sig, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (sig, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) |
| { |
| if (!type_check (pid, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (pid, 0)) |
| return false; |
| |
| if (!type_check (sig, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (sig, 1)) |
| return false; |
| |
| if (status) |
| { |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_kind (gfc_expr *x) |
| { |
| if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of " |
| "intrinsic type", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &x->where); |
| return false; |
| } |
| if (x->ts.type == BT_PROCEDURE) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &x->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, 1)) |
| return false; |
| |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (!coarray_check (coarray, 0)) |
| return false; |
| |
| if (dim != NULL) |
| { |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_corank_check (dim, coarray)) |
| return false; |
| } |
| |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) |
| { |
| if (!type_check (s, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!kind_check (kind, 1, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) |
| { |
| if (!type_check (a, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (a, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (b, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (b, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_link (gfc_expr *path1, gfc_expr *path2) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_loc (gfc_expr *expr) |
| { |
| return variable_check (expr, 0, true); |
| } |
| |
| |
| bool |
| gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 1, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_logical (gfc_expr *a, gfc_expr *kind) |
| { |
| if (!type_check (a, 0, BT_LOGICAL)) |
| return false; |
| if (!kind_check (kind, 1, BT_LOGICAL)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Min/max family. */ |
| |
| static bool |
| min_max_args (gfc_actual_arglist *args) |
| { |
| gfc_actual_arglist *arg; |
| int i, j, nargs, *nlabels, nlabelless; |
| bool a1 = false, a2 = false; |
| |
| if (args == NULL || args->next == NULL) |
| { |
| gfc_error ("Intrinsic %qs at %L must have at least two arguments", |
| gfc_current_intrinsic, gfc_current_intrinsic_where); |
| return false; |
| } |
| |
| if (!args->name) |
| a1 = true; |
| |
| if (!args->next->name) |
| a2 = true; |
| |
| nargs = 0; |
| for (arg = args; arg; arg = arg->next) |
| if (arg->name) |
| nargs++; |
| |
| if (nargs == 0) |
| return true; |
| |
| /* Note: Having a keywordless argument after an "arg=" is checked before. */ |
| nlabelless = 0; |
| nlabels = XALLOCAVEC (int, nargs); |
| for (arg = args, i = 0; arg; arg = arg->next, i++) |
| if (arg->name) |
| { |
| int n; |
| char *endp; |
| |
| if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9') |
| goto unknown; |
| n = strtol (&arg->name[1], &endp, 10); |
| if (endp[0] != '\0') |
| goto unknown; |
| if (n <= 0) |
| goto unknown; |
| if (n <= nlabelless) |
| goto duplicate; |
| nlabels[i] = n; |
| if (n == 1) |
| a1 = true; |
| if (n == 2) |
| a2 = true; |
| } |
| else |
| nlabelless++; |
| |
| if (!a1 || !a2) |
| { |
| gfc_error ("Missing %qs argument to the %s intrinsic at %L", |
| !a1 ? "a1" : "a2", gfc_current_intrinsic, |
| gfc_current_intrinsic_where); |
| return false; |
| } |
| |
| /* Check for duplicates. */ |
| for (i = 0; i < nargs; i++) |
| for (j = i + 1; j < nargs; j++) |
| if (nlabels[i] == nlabels[j]) |
| goto duplicate; |
| |
| return true; |
| |
| duplicate: |
| gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, |
| &arg->expr->where, gfc_current_intrinsic); |
| return false; |
| |
| unknown: |
| gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, |
| &arg->expr->where, gfc_current_intrinsic); |
| return false; |
| } |
| |
| |
| static bool |
| check_rest (bt type, int kind, gfc_actual_arglist *arglist) |
| { |
| gfc_actual_arglist *arg, *tmp; |
| gfc_expr *x; |
| int m, n; |
| |
| if (!min_max_args (arglist)) |
| return false; |
| |
| for (arg = arglist, n=1; arg; arg = arg->next, 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, "Different type " |
| "kinds at %L", &x->where)) |
| return false; |
| } |
| else |
| { |
| gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be " |
| "%s(%d)", n, gfc_current_intrinsic, &x->where, |
| gfc_basic_typename (type), kind); |
| return false; |
| } |
| } |
| |
| for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) |
| if (!gfc_check_conformance (tmp->expr, x, |
| "arguments 'a%d' and 'a%d' for " |
| "intrinsic '%s'", m, n, |
| gfc_current_intrinsic)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_min_max (gfc_actual_arglist *arg) |
| { |
| gfc_expr *x; |
| |
| if (!min_max_args (arg)) |
| return false; |
| |
| x = arg->expr; |
| |
| if (x->ts.type == BT_CHARACTER) |
| { |
| if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with CHARACTER argument at %L", |
| gfc_current_intrinsic, &x->where)) |
| return false; |
| } |
| else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) |
| { |
| gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, " |
| "REAL or CHARACTER", gfc_current_intrinsic, &x->where); |
| return false; |
| } |
| |
| return check_rest (x->ts.type, x->ts.kind, arg); |
| } |
| |
| |
| bool |
| gfc_check_min_max_integer (gfc_actual_arglist *arg) |
| { |
| return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); |
| } |
| |
| |
| bool |
| gfc_check_min_max_real (gfc_actual_arglist *arg) |
| { |
| return check_rest (BT_REAL, gfc_default_real_kind, arg); |
| } |
| |
| |
| bool |
| gfc_check_min_max_double (gfc_actual_arglist *arg) |
| { |
| return check_rest (BT_REAL, gfc_default_double_kind, arg); |
| } |
| |
| |
| /* End of min/max family. */ |
| |
| bool |
| gfc_check_malloc (gfc_expr *size) |
| { |
| if (!type_check (size, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (size, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) |
| { |
| if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " |
| "or LOGICAL", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &matrix_a->where); |
| return false; |
| } |
| |
| if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " |
| "or LOGICAL", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &matrix_b->where); |
| return false; |
| } |
| |
| if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) |
| || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) |
| { |
| gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", |
| gfc_current_intrinsic, &matrix_a->where, |
| gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); |
| return false; |
| } |
| |
| switch (matrix_a->rank) |
| { |
| case 1: |
| if (!rank_check (matrix_b, 1, 2)) |
| return false; |
| /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ |
| if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) |
| { |
| gfc_error ("Different shape on dimension 1 for arguments %qs " |
| "and %qs at %L for intrinsic matmul", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, &matrix_a->where); |
| return false; |
| } |
| break; |
| |
| case 2: |
| if (matrix_b->rank != 2) |
| { |
| if (!rank_check (matrix_b, 1, 1)) |
| return false; |
| } |
| /* 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)) |
| { |
| gfc_error ("Different shape on dimension 2 for argument %qs and " |
| "dimension 1 for argument %qs at %L for intrinsic " |
| "matmul", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, &matrix_a->where); |
| return false; |
| } |
| break; |
| |
| default: |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " |
| "1 or 2", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &matrix_a->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Whoever came up with this interface was probably on something. |
| 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 |
| |
| 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. Also, |
| add the BACK argument if that isn't present. */ |
| |
| bool |
| gfc_check_minloc_maxloc (gfc_actual_arglist *ap) |
| { |
| gfc_expr *a, *m, *d, *k, *b; |
| |
| a = ap->expr; |
| if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0)) |
| return false; |
| |
| d = ap->next->expr; |
| m = ap->next->next->expr; |
| k = ap->next->next->next->expr; |
| b = ap->next->next->next->next->expr; |
| |
| if (b) |
| { |
| if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4)) |
| return false; |
| } |
| else |
| { |
| b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); |
| ap->next->next->next->next->expr = b; |
| } |
| |
| if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL |
| && ap->next->name == NULL) |
| { |
| m = d; |
| d = NULL; |
| ap->next->expr = NULL; |
| ap->next->next->expr = m; |
| } |
| |
| if (!dim_check (d, 1, false)) |
| return false; |
| |
| if (!dim_rank_check (d, a, 0)) |
| return false; |
| |
| if (m != NULL && !type_check (m, 2, BT_LOGICAL)) |
| return false; |
| |
| if (m != NULL |
| && !gfc_check_conformance (a, m, |
| "arguments '%s' and '%s' for intrinsic %s", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic)) |
| return false; |
| |
| if (!kind_check (k, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| /* Check function for findloc. Mostly like gfc_check_minloc_maxloc |
| above, with the additional "value" argument. */ |
| |
| bool |
| gfc_check_findloc (gfc_actual_arglist *ap) |
| { |
| gfc_expr *a, *v, *m, *d, *k, *b; |
| |
| a = ap->expr; |
| if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) |
| return false; |
| |
| v = ap->next->expr; |
| if (!scalar_check (v,1)) |
| return false; |
| |
| /* Check if the type is compatible. */ |
| |
| if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL) |
| || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL)) |
| { |
| gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " |
| "conformance to argument %qs at %L", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &a->where, |
| gfc_current_intrinsic_arg[1]->name, &v->where); |
| } |
| |
| d = ap->next->next->expr; |
| m = ap->next->next->next->expr; |
| k = ap->next->next->next->next->expr; |
| b = ap->next->next->next->next->next->expr; |
| |
| if (b) |
| { |
| if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4)) |
| return false; |
| } |
| else |
| { |
| b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); |
| ap->next->next->next->next->next->expr = b; |
| } |
| |
| if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL |
| && ap->next->name == NULL) |
| { |
| m = d; |
| d = NULL; |
| ap->next->next->expr = NULL; |
| ap->next->next->next->expr = m; |
| } |
| |
| if (!dim_check (d, 2, false)) |
| return false; |
| |
| if (!dim_rank_check (d, a, 0)) |
| return false; |
| |
| if (m != NULL && !type_check (m, 3, BT_LOGICAL)) |
| return false; |
| |
| if (m != NULL |
| && !gfc_check_conformance (a, m, |
| "arguments '%s' and '%s' for intrinsic %s", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[3]->name, |
| gfc_current_intrinsic)) |
| return false; |
| |
| if (!kind_check (k, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Similar to minloc/maxloc, the argument list might need to be |
| reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The |
| 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 |
| |
| 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 bool |
| check_reduction (gfc_actual_arglist *ap) |
| { |
| gfc_expr *a, *m, *d; |
| |
| a = ap->expr; |
| d = ap->next->expr; |
| m = ap->next->next->expr; |
| |
| if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL |
| && ap->next->name == NULL) |
| { |
| m = d; |
| d = NULL; |
| ap->next->expr = NULL; |
| ap->next->next->expr = m; |
| } |
| |
| if (!dim_check (d, 1, false)) |
| return false; |
| |
| if (!dim_rank_check (d, a, 0)) |
| return false; |
| |
| if (m != NULL && !type_check (m, 2, BT_LOGICAL)) |
| return false; |
| |
| if (m != NULL |
| && !gfc_check_conformance (a, m, |
| "arguments '%s' and '%s' for intrinsic %s", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_minval_maxval (gfc_actual_arglist *ap) |
| { |
| if (!int_or_real_or_char_check_f2003 (ap->expr, 0) |
| || !array_check (ap->expr, 0)) |
| return false; |
| |
| return check_reduction (ap); |
| } |
| |
| |
| bool |
| gfc_check_product_sum (gfc_actual_arglist *ap) |
| { |
| if (!numeric_check (ap->expr, 0) |
| || !array_check (ap->expr, 0)) |
| return false; |
| |
| return check_reduction (ap); |
| } |
| |
| |
| /* For IANY, IALL and IPARITY. */ |
| |
| bool |
| gfc_check_mask (gfc_expr *i, gfc_expr *kind) |
| { |
| int k; |
| |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("I", i)) |
| return false; |
| |
| if (!kind_check (kind, 1, BT_INTEGER)) |
| return false; |
| |
| if (kind) |
| gfc_extract_int (kind, &k); |
| else |
| k = gfc_default_integer_kind; |
| |
| if (!less_than_bitsizekind ("I", i, k)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) |
| { |
| if (ap->expr->ts.type != BT_INTEGER) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &ap->expr->where); |
| return false; |
| } |
| |
| if (!array_check (ap->expr, 0)) |
| return false; |
| |
| return check_reduction (ap); |
| } |
| |
| |
| bool |
| gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) |
| { |
| if (!same_type_check (tsource, 0, fsource, 1)) |
| return false; |
| |
| if (!type_check (mask, 2, BT_LOGICAL)) |
| return false; |
| |
| if (tsource->ts.type == BT_CHARACTER) |
| return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (j, 1, BT_INTEGER)) |
| return false; |
| |
| if (!boz_args_check (i, j)) |
| return false; |
| |
| if (i->is_boz) i->ts.kind = j->ts.kind; |
| if (j->is_boz) j->ts.kind = i->ts.kind; |
| |
| if (!type_check (mask, 2, BT_INTEGER)) |
| return false; |
| |
| if (!same_type_check (i, 0, j, 1)) |
| return false; |
| |
| if (!same_type_check (i, 0, mask, 2)) |
| return false; |
| |
| if (mask->is_boz) mask->ts.kind = i->ts.kind; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) |
| { |
| if (!variable_check (from, 0, false)) |
| return false; |
| if (!allocatable_check (from, 0)) |
| return false; |
| if (gfc_is_coindexed (from)) |
| { |
| gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be " |
| "coindexed", &from->where); |
| return false; |
| } |
| |
| if (!variable_check (to, 1, false)) |
| return false; |
| if (!allocatable_check (to, 1)) |
| return false; |
| if (gfc_is_coindexed (to)) |
| { |
| gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be " |
| "coindexed", &to->where); |
| return false; |
| } |
| |
| if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) |
| { |
| gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " |
| "polymorphic if FROM is polymorphic", |
| &to->where); |
| return false; |
| } |
| |
| if (!same_type_check (to, 1, from, 0)) |
| return false; |
| |
| if (to->rank != from->rank) |
| { |
| gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " |
| "must have the same rank %d/%d", &to->where, from->rank, |
| to->rank); |
| return false; |
| } |
| |
| /* IR F08/0040; cf. 12-006A. */ |
| if (gfc_get_corank (to) != gfc_get_corank (from)) |
| { |
| gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " |
| "must have the same corank %d/%d", &to->where, |
| gfc_get_corank (from), gfc_get_corank (to)); |
| return false; |
| } |
| |
| /* This is based losely on F2003 12.4.1.7. It is intended to prevent |
| the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1 |
| and cmp2 are allocatable. After the allocation is transferred, |
| the 'to' chain is broken by the nullification of the 'from'. A bit |
| of reflection reveals that this can only occur for derived types |
| with recursive allocatable components. */ |
| if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE |
| && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name)) |
| { |
| gfc_ref *to_ref, *from_ref; |
| to_ref = to->ref; |
| from_ref = from->ref; |
| bool aliasing = true; |
| |
| for (; from_ref && to_ref; |
| from_ref = from_ref->next, to_ref = to_ref->next) |
| { |
| if (to_ref->type != from->ref->type) |
| aliasing = false; |
| else if (to_ref->type == REF_ARRAY |
| && to_ref->u.ar.type != AR_FULL |
| && from_ref->u.ar.type != AR_FULL) |
| /* Play safe; assume sections and elements are different. */ |
| aliasing = false; |
| else if (to_ref->type == REF_COMPONENT |
| && to_ref->u.c.component != from_ref->u.c.component) |
| aliasing = false; |
| |
| if (!aliasing) |
| break; |
| } |
| |
| if (aliasing) |
| { |
| gfc_error ("The FROM and TO arguments at %L violate aliasing " |
| "restrictions (F2003 12.4.1.7)", &to->where); |
| return false; |
| } |
| } |
| |
| /* CLASS arguments: Make sure the vtab of from is present. */ |
| if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) |
| gfc_find_vtab (&from->ts); |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_nearest (gfc_expr *x, gfc_expr *s) |
| { |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| |
| if (!type_check (s, 1, BT_REAL)) |
| return false; |
| |
| if (s->expr_type == EXPR_CONSTANT) |
| { |
| if (mpfr_sgn (s->value.real) == 0) |
| { |
| gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero", |
| &s->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_new_line (gfc_expr *a) |
| { |
| if (!type_check (a, 0, BT_CHARACTER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) |
| { |
| if (!type_check (array, 0, BT_REAL)) |
| return false; |
| |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, false)) |
| return false; |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_null (gfc_expr *mold) |
| { |
| symbol_attribute attr; |
| |
| if (mold == NULL) |
| return true; |
| |
| if (!variable_check (mold, 0, true)) |
| return false; |
| |
| attr = gfc_variable_attr (mold, NULL); |
| |
| if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " |
| "ALLOCATABLE or procedure pointer", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &mold->where); |
| return false; |
| } |
| |
| if (attr.allocatable |
| && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " |
| "allocatable MOLD at %L", &mold->where)) |
| return false; |
| |
| /* F2008, C1242. */ |
| if (gfc_is_coindexed (mold)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be " |
| "coindexed", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &mold->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!type_check (mask, 1, BT_LOGICAL)) |
| return false; |
| |
| if (!gfc_check_conformance (array, mask, |
| "arguments '%s' and '%s' for intrinsic '%s'", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic)) |
| return false; |
| |
| if (vector != NULL) |
| { |
| mpz_t array_size, vector_size; |
| bool have_array_size, have_vector_size; |
| |
| if (!same_type_check (array, 0, vector, 2)) |
| return false; |
| |
| if (!rank_check (vector, 2, 1)) |
| return false; |
| |
| /* VECTOR requires at least as many elements as MASK |
| has .TRUE. values. */ |
| have_array_size = gfc_array_size(array, &array_size); |
| have_vector_size = gfc_array_size(vector, &vector_size); |
| |
| if (have_vector_size |
| && (mask->expr_type == EXPR_ARRAY |
| || (mask->expr_type == EXPR_CONSTANT |
| && have_array_size))) |
| { |
| int mask_true_values = 0; |
| |
| if (mask->expr_type == EXPR_ARRAY) |
| { |
| gfc_constructor *mask_ctor; |
| mask_ctor = gfc_constructor_first (mask->value.constructor); |
| while (mask_ctor) |
| { |
| if (mask_ctor->expr->expr_type != EXPR_CONSTANT) |
| { |
| mask_true_values = 0; |
| break; |
| } |
| |
| if (mask_ctor->expr->value.logical) |
| mask_true_values++; |
| |
| mask_ctor = gfc_constructor_next (mask_ctor); |
| } |
| } |
| else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) |
| mask_true_values = mpz_get_si (array_size); |
| |
| if (mpz_get_si (vector_size) < mask_true_values) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must " |
| "provide at least as many elements as there " |
| "are .TRUE. values in %qs (%ld/%d)", |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic, &vector->where, |
| gfc_current_intrinsic_arg[1]->name, |
| mpz_get_si (vector_size), mask_true_values); |
| return false; |
| } |
| } |
| |
| if (have_array_size) |
| mpz_clear (array_size); |
| if (have_vector_size) |
| mpz_clear (vector_size); |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_parity (gfc_expr *mask, gfc_expr *dim) |
| { |
| if (!type_check (mask, 0, BT_LOGICAL)) |
| return false; |
| |
| if (!array_check (mask, 0)) |
| return false; |
| |
| if (!dim_rank_check (dim, mask, false)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_precision (gfc_expr *x) |
| { |
| if (!real_or_complex_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_present (gfc_expr *a) |
| { |
| gfc_symbol *sym; |
| |
| if (!variable_check (a, 0, true)) |
| return false; |
| |
| sym = a->symtree->n.sym; |
| if (!sym->attr.dummy) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of a " |
| "dummy variable", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &a->where); |
| return false; |
| } |
| |
| if (!sym->attr.optional) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of " |
| "an OPTIONAL dummy variable", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &a->where); |
| return false; |
| } |
| |
| /* 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->u.ar.type == AR_ELEMENT |
| && a->ref->u.ar.as->rank == 0)))) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must not be a " |
| "subobject of %qs", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &a->where, sym->name); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_radix (gfc_expr *x) |
| { |
| if (!int_or_real_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_range (gfc_expr *x) |
| { |
| if (!numeric_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_rank (gfc_expr *a) |
| { |
| /* Any data object is allowed; a "data object" is a "constant (4.1.3), |
| variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */ |
| |
| bool is_variable = true; |
| |
| /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ |
| if (a->expr_type == EXPR_FUNCTION) |
| is_variable = a->value.function.esym |
| ? a->value.function.esym->result->attr.pointer |
| : a->symtree->n.sym->result->attr.pointer; |
| |
| if (a->expr_type == EXPR_OP |
| || a->expr_type == EXPR_NULL |
| || a->expr_type == EXPR_COMPCALL |
| || a->expr_type == EXPR_PPC |
| || a->ts.type == BT_PROCEDURE |
| || !is_variable) |
| { |
| gfc_error ("The argument of the RANK intrinsic at %L must be a data " |
| "object", &a->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* real, float, sngl. */ |
| bool |
| gfc_check_real (gfc_expr *a, gfc_expr *kind) |
| { |
| if (!numeric_check (a, 0)) |
| return false; |
| |
| if (!kind_check (kind, 1, BT_REAL)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_rename (gfc_expr *path1, gfc_expr *path2) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) |
| { |
| if (!type_check (path1, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path1, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (path2, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (path2, 1, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_repeat (gfc_expr *x, gfc_expr *y) |
| { |
| if (!type_check (x, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| if (!type_check (y, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (y, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_reshape (gfc_expr *source, gfc_expr *shape, |
| gfc_expr *pad, gfc_expr *order) |
| { |
| mpz_t size; |
| mpz_t nelems; |
| int shape_size; |
| |
| if (!array_check (source, 0)) |
| return false; |
| |
| if (!rank_check (shape, 1, 1)) |
| return false; |
| |
| if (!type_check (shape, 1, BT_INTEGER)) |
| return false; |
| |
| if (!gfc_array_size (shape, &size)) |
| { |
| gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an " |
| "array of constant size", &shape->where); |
| return false; |
| } |
| |
| shape_size = mpz_get_ui (size); |
| mpz_clear (size); |
| |
| if (shape_size <= 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L is empty", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &shape->where); |
| return false; |
| } |
| else if (shape_size > GFC_MAX_DIMENSIONS) |
| { |
| gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more " |
| "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); |
| return false; |
| } |
| else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) |
| { |
| gfc_expr *e; |
| int i, extent; |
| for (i = 0; i < shape_size; ++i) |
| { |
| e = gfc_constructor_lookup_expr (shape->value.constructor, i); |
| if (e->expr_type != EXPR_CONSTANT) |
| continue; |
| |
| gfc_extract_int (e, &extent); |
| if (extent < 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L has " |
| "negative element (%d)", |
| gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &e->where, extent); |
| return false; |
| } |
| } |
| } |
| else if (shape->expr_type == EXPR_VARIABLE && shape->ref |
| && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1 |
| && shape->ref->u.ar.as |
| && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT |
| && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER |
| && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT |
| && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER |
| && shape->symtree->n.sym->attr.flavor == FL_PARAMETER) |
| { |
| int i, extent; |
| gfc_expr *e, *v; |
| |
| v = shape->symtree->n.sym->value; |
| |
| for (i = 0; i < shape_size; i++) |
| { |
| e = gfc_constructor_lookup_expr (v->value.constructor, i); |
| if (e == NULL) |
| break; |
| |
| gfc_extract_int (e, &extent); |
| |
| if (extent < 0) |
| { |
| gfc_error ("Element %d of actual argument of RESHAPE at %L " |
| "cannot be negative", i + 1, &shape->where); |
| return false; |
| } |
| } |
| } |
| |
| if (pad != NULL) |
| { |
| if (!same_type_check (source, 0, pad, 2)) |
| return false; |
| |
| if (!array_check (pad, 2)) |
| return false; |
| } |
| |
| if (order != NULL) |
| { |
| if (!array_check (order, 3)) |
| return false; |
| |
| if (!type_check (order, 3, BT_INTEGER)) |
| return false; |
| |
| if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order)) |
| { |
| int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; |
| gfc_expr *e; |
| |
| for (i = 0; i < GFC_MAX_DIMENSIONS; ++i) |
| perm[i] = 0; |
| |
| gfc_array_size (order, &size); |
| order_size = mpz_get_ui (size); |
| mpz_clear (size); |
| |
| if (order_size != shape_size) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "has wrong number of elements (%d/%d)", |
| gfc_current_intrinsic_arg[3]->name, |
| gfc_current_intrinsic, &order->where, |
| order_size, shape_size); |
| return false; |
| } |
| |
| for (i = 1; i <= order_size; ++i) |
| { |
| e = gfc_constructor_lookup_expr (order->value.constructor, i-1); |
| if (e->expr_type != EXPR_CONSTANT) |
| continue; |
| |
| gfc_extract_int (e, &dim); |
| |
| if (dim < 1 || dim > order_size) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "has out-of-range dimension (%d)", |
| gfc_current_intrinsic_arg[3]->name, |
| gfc_current_intrinsic, &e->where, dim); |
| return false; |
| } |
| |
| if (perm[dim-1] != 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L has " |
| "invalid permutation of dimensions (dimension " |
| "%qd duplicated)", |
| gfc_current_intrinsic_arg[3]->name, |
| gfc_current_intrinsic, &e->where, dim); |
| return false; |
| } |
| |
| perm[dim-1] = 1; |
| } |
| } |
| } |
| |
| 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)) |
| { |
| gfc_constructor *c; |
| bool test; |
| |
| |
| mpz_init_set_ui (size, 1); |
| for (c = gfc_constructor_first (shape->value.constructor); |
| c; c = gfc_constructor_next (c)) |
| mpz_mul (size, size, c->expr->value.integer); |
| |
| test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; |
| mpz_clear (nelems); |
| mpz_clear (size); |
| |
| if (test) |
| { |
| gfc_error ("Without padding, there are not enough elements " |
| "in the intrinsic RESHAPE source at %L to match " |
| "the shape", &source->where); |
| return false; |
| } |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) |
| { |
| if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "cannot be of type %s", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, |
| &a->where, gfc_typename (&a->ts)); |
| return false; |
| } |
| |
| if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "must be of an extensible type", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &a->where); |
| return false; |
| } |
| |
| if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "cannot be of type %s", |
| gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, |
| &b->where, gfc_typename (&b->ts)); |
| return false; |
| } |
| |
| if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L " |
| "must be of an extensible type", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &b->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_scale (gfc_expr *x, gfc_expr *i) |
| { |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| |
| if (!type_check (i, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) |
| { |
| if (!type_check (x, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!type_check (y, 1, BT_CHARACTER)) |
| return false; |
| |
| if (z != NULL && !type_check (z, 2, BT_LOGICAL)) |
| return false; |
| |
| if (!kind_check (kind, 3, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| if (!same_type_check (x, 0, y, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_secnds (gfc_expr *r) |
| { |
| if (!type_check (r, 0, BT_REAL)) |
| return false; |
| |
| if (!kind_value_check (r, 0, 4)) |
| return false; |
| |
| if (!scalar_check (r, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_selected_char_kind (gfc_expr *name) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!scalar_check (name, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_selected_int_kind (gfc_expr *r) |
| { |
| if (!type_check (r, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (r, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) |
| { |
| if (p == NULL && r == NULL |
| && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" |
| " neither %<P%> nor %<R%> argument at %L", |
| gfc_current_intrinsic_where)) |
| return false; |
| |
| if (p) |
| { |
| if (!type_check (p, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (p, 0)) |
| return false; |
| } |
| |
| if (r) |
| { |
| if (!type_check (r, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (r, 1)) |
| return false; |
| } |
| |
| if (radix) |
| { |
| if (!type_check (radix, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (radix, 1)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with " |
| "RADIX argument at %L", gfc_current_intrinsic, |
| &radix->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) |
| { |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| |
| if (!type_check (i, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_shape (gfc_expr *source, gfc_expr *kind) |
| { |
| gfc_array_ref *ar; |
| |
| if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) |
| return true; |
| |
| ar = gfc_find_array_ref (source); |
| |
| if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL) |
| { |
| gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be " |
| "an assumed size array", &source->where); |
| return false; |
| } |
| |
| if (!kind_check (kind, 1, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_shift (gfc_expr *i, gfc_expr *shift) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (shift, 0, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("SHIFT", shift)) |
| return false; |
| |
| if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_sign (gfc_expr *a, gfc_expr *b) |
| { |
| if (!int_or_real_check (a, 0)) |
| return false; |
| |
| if (!same_type_check (a, 0, b, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!dim_check (dim, 1, true)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, 0)) |
| return false; |
| |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_sizeof (gfc_expr *arg) |
| { |
| if (arg->ts.type == BT_PROCEDURE) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &arg->where); |
| return false; |
| } |
| |
| /* TYPE(*) is acceptable if and only if it uses an array descriptor. */ |
| if (arg->ts.type == BT_ASSUMED |
| && (arg->symtree->n.sym->as == NULL |
| || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE |
| && arg->symtree->n.sym->as->type != AS_DEFERRED |
| && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &arg->where); |
| return false; |
| } |
| |
| if (arg->rank && arg->expr_type == EXPR_VARIABLE |
| && arg->symtree->n.sym->as != NULL |
| && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref |
| && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " |
| "assumed-size array", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &arg->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Check whether an expression is interoperable. When returning false, |
| msg is set to a string telling why the expression is not interoperable, |
| otherwise, it is set to NULL. The msg string can be used in diagnostics. |
| If c_loc is true, character with len > 1 are allowed (cf. Fortran |
| 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape |
| arrays are permitted. And if c_f_ptr is true, deferred-shape arrays |
| are permitted. */ |
| |
| static bool |
| is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) |
| { |
| *msg = NULL; |
| |
| if (expr->ts.type == BT_CLASS) |
| { |
| *msg = "Expression is polymorphic"; |
| return false; |
| } |
| |
| if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c |
| && !expr->ts.u.derived->ts.is_iso_c) |
| { |
| *msg = "Expression is a noninteroperable derived type"; |
| return false; |
| } |
| |
| if (expr->ts.type == BT_PROCEDURE) |
| { |
| *msg = "Procedure unexpected as argument"; |
| return false; |
| } |
| |
| if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL) |
| { |
| int i; |
| for (i = 0; gfc_logical_kinds[i].kind; i++) |
| if (gfc_logical_kinds[i].kind == expr->ts.kind) |
| return true; |
| *msg = "Extension to use a non-C_Bool-kind LOGICAL"; |
| return false; |
| } |
| |
| if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER |
| && expr->ts.kind != 1) |
| { |
| *msg = "Extension to use a non-C_CHAR-kind CHARACTER"; |
| return false; |
| } |
| |
| if (expr->ts.type == BT_CHARACTER) { |
| if (expr->ts.deferred) |
| { |
| /* TS 29113 allows deferred-length strings as dummy arguments, |
| but it is not an interoperable type. */ |
| *msg = "Expression shall not be a deferred-length string"; |
| return false; |
| } |
| |
| if (expr->ts.u.cl && expr->ts.u.cl->length |
| && !gfc_simplify_expr (expr->ts.u.cl->length, 0)) |
| gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); |
| |
| if (!c_loc && expr->ts.u.cl |
| && (!expr->ts.u.cl->length |
| || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT |
| || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) |
| { |
| *msg = "Type shall have a character length of 1"; |
| return false; |
| } |
| } |
| |
| /* Note: The following checks are about interoperatable variables, Fortran |
| 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more |
| is allowed, e.g. assumed-shape arrays with TS 29113. */ |
| |
| if (gfc_is_coarray (expr)) |
| { |
| *msg = "Coarrays are not interoperable"; |
| return false; |
| } |
| |
| if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) |
| { |
| gfc_array_ref *ar = gfc_find_array_ref (expr); |
| if (ar->type != AR_FULL) |
| { |
| *msg = "Only whole-arrays are interoperable"; |
| return false; |
| } |
| if (!c_f_ptr && ar->as->type != AS_EXPLICIT |
| && ar->as->type != AS_ASSUMED_SIZE) |
| { |
| *msg = "Only explicit-size and assumed-size arrays are interoperable"; |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_sizeof (gfc_expr *arg) |
| { |
| const char *msg; |
| |
| if (!is_c_interoperable (arg, &msg, false, false)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be an " |
| "interoperable data entity: %s", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &arg->where, msg); |
| return false; |
| } |
| |
| if (arg->ts.type == BT_ASSUMED) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be " |
| "TYPE(*)", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &arg->where); |
| return false; |
| } |
| |
| if (arg->rank && arg->expr_type == EXPR_VARIABLE |
| && arg->symtree->n.sym->as != NULL |
| && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref |
| && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " |
| "assumed-size array", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &arg->where); |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) |
| { |
| if (c_ptr_1->ts.type != BT_DERIVED |
| || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING |
| || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR |
| && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) |
| { |
| gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " |
| "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); |
| return false; |
| } |
| |
| if (!scalar_check (c_ptr_1, 0)) |
| return false; |
| |
| if (c_ptr_2 |
| && (c_ptr_2->ts.type != BT_DERIVED |
| || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING |
| || (c_ptr_1->ts.u.derived->intmod_sym_id |
| != c_ptr_2->ts.u.derived->intmod_sym_id))) |
| { |
| gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " |
| "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, |
| gfc_typename (&c_ptr_1->ts), |
| gfc_typename (&c_ptr_2->ts)); |
| return false; |
| } |
| |
| if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) |
| { |
| symbol_attribute attr; |
| const char *msg; |
| |
| if (cptr->ts.type != BT_DERIVED |
| || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING |
| || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR) |
| { |
| gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the " |
| "type TYPE(C_PTR)", &cptr->where); |
| return false; |
| } |
| |
| if (!scalar_check (cptr, 0)) |
| return false; |
| |
| attr = gfc_expr_attr (fptr); |
| |
| if (!attr.pointer) |
| { |
| gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer", |
| &fptr->where); |
| return false; |
| } |
| |
| if (fptr->ts.type == BT_CLASS) |
| { |
| gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic", |
| &fptr->where); |
| return false; |
| } |
| |
| if (gfc_is_coindexed (fptr)) |
| { |
| gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be " |
| "coindexed", &fptr->where); |
| return false; |
| } |
| |
| if (fptr->rank == 0 && shape) |
| { |
| gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar " |
| "FPTR", &fptr->where); |
| return false; |
| } |
| else if (fptr->rank && !shape) |
| { |
| gfc_error ("Expected SHAPE argument to C_F_POINTER with array " |
| "FPTR at %L", &fptr->where); |
| return false; |
| } |
| |
| if (shape && !rank_check (shape, 2, 1)) |
| return false; |
| |
| if (shape && !type_check (shape, 2, BT_INTEGER)) |
| return false; |
| |
| if (shape) |
| { |
| mpz_t size; |
| if (gfc_array_size (shape, &size)) |
| { |
| if (mpz_cmp_ui (size, fptr->rank) != 0) |
| { |
| mpz_clear (size); |
| gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same " |
| "size as the RANK of FPTR", &shape->where); |
| return false; |
| } |
| mpz_clear (size); |
| } |
| } |
| |
| if (fptr->ts.type == BT_CLASS) |
| { |
| gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); |
| return false; |
| } |
| |
| if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true)) |
| return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR " |
| "at %L to C_F_POINTER: %s", &fptr->where, msg); |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) |
| { |
| symbol_attribute attr; |
| |
| if (cptr->ts.type != BT_DERIVED |
| || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING |
| || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR) |
| { |
| gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the " |
| "type TYPE(C_FUNPTR)", &cptr->where); |
| return false; |
| } |
| |
| if (!scalar_check (cptr, 0)) |
| return false; |
| |
| attr = gfc_expr_attr (fptr); |
| |
| if (!attr.proc_pointer) |
| { |
| gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure " |
| "pointer", &fptr->where); |
| return false; |
| } |
| |
| if (gfc_is_coindexed (fptr)) |
| { |
| gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be " |
| "coindexed", &fptr->where); |
| return false; |
| } |
| |
| if (!attr.is_bind_c) |
| return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " |
| "pointer at %L to C_F_PROCPOINTER", &fptr->where); |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_funloc (gfc_expr *x) |
| { |
| symbol_attribute attr; |
| |
| if (gfc_is_coindexed (x)) |
| { |
| gfc_error ("Argument X at %L to C_FUNLOC shall not be " |
| "coindexed", &x->where); |
| return false; |
| } |
| |
| attr = gfc_expr_attr (x); |
| |
| if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE |
| && x->symtree->n.sym == x->symtree->n.sym->result) |
| { |
| gfc_namespace *ns = gfc_current_ns; |
| |
| for (ns = gfc_current_ns; ns; ns = ns->parent) |
| if (x->symtree->n.sym == ns->proc_name) |
| { |
| gfc_error ("Function result %qs at %L is invalid as X argument " |
| "to C_FUNLOC", x->symtree->n.sym->name, &x->where); |
| return false; |
| } |
| } |
| |
| if (attr.flavor != FL_PROCEDURE) |
| { |
| gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure " |
| "or a procedure pointer", &x->where); |
| return false; |
| } |
| |
| if (!attr.is_bind_c) |
| return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " |
| "at %L to C_FUNLOC", &x->where); |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_c_loc (gfc_expr *x) |
| { |
| symbol_attribute attr; |
| const char *msg; |
| |
| if (gfc_is_coindexed (x)) |
| { |
| gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where); |
| return false; |
| } |
| |
| if (x->ts.type == BT_CLASS) |
| { |
| gfc_error ("X argument at %L to C_LOC shall not be polymorphic", |
| &x->where); |
| return false; |
| } |
| |
| attr = gfc_expr_attr (x); |
| |
| if (!attr.pointer |
| && (x->expr_type != EXPR_VARIABLE || !attr.target |
| || attr.flavor == FL_PARAMETER)) |
| { |
| gfc_error ("Argument X at %L to C_LOC shall have either " |
| "the POINTER or the TARGET attribute", &x->where); |
| return false; |
| } |
| |
| if (x->ts.type == BT_CHARACTER |
| && gfc_var_strlen (x) == 0) |
| { |
| gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized " |
| "string", &x->where); |
| return false; |
| } |
| |
| if (!is_c_interoperable (x, &msg, true, false)) |
| { |
| if (x->ts.type == BT_CLASS) |
| { |
| gfc_error ("Argument at %L to C_LOC shall not be polymorphic", |
| &x->where); |
| return false; |
| } |
| |
| if (x->rank |
| && !gfc_notify_std (GFC_STD_F2018, |
| "Noninteroperable array at %L as" |
| " argument to C_LOC: %s", &x->where, msg)) |
| return false; |
| } |
| else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008)) |
| { |
| gfc_array_ref *ar = gfc_find_array_ref (x); |
| |
| if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE |
| && !attr.allocatable |
| && !gfc_notify_std (GFC_STD_F2008, |
| "Array of interoperable type at %L " |
| "to C_LOC which is nonallocatable and neither " |
| "assumed size nor explicit size", &x->where)) |
| return false; |
| else if (ar->type != AR_FULL |
| && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " |
| "to C_LOC", &x->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_sleep_sub (gfc_expr *seconds) |
| { |
| if (!type_check (seconds, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (seconds, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_sngl (gfc_expr *a) |
| { |
| if (!type_check (a, 0, BT_REAL)) |
| return false; |
| |
| if ((a->ts.kind != gfc_default_double_kind) |
| && !gfc_notify_std (GFC_STD_GNU, "non double precision " |
| "REAL argument to %s intrinsic at %L", |
| gfc_current_intrinsic, &a->where)) |
| return false; |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) |
| { |
| if (source->rank >= GFC_MAX_DIMENSIONS) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be less " |
| "than rank %d", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); |
| |
| return false; |
| } |
| |
| if (dim == NULL) |
| return false; |
| |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| /* dim_rank_check() does not apply here. */ |
| if (dim |
| && dim->expr_type == EXPR_CONSTANT |
| && (mpz_cmp_ui (dim->value.integer, 1) < 0 |
| || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " |
| "dimension index", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &dim->where); |
| return false; |
| } |
| |
| if (!type_check (ncopies, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (ncopies, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and |
| functions). */ |
| |
| bool |
| gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (c, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (c, 1, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER) |
| || !kind_value_check (status, 2, gfc_default_integer_kind) |
| || !scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) |
| { |
| return gfc_check_fgetputc_sub (unit, c, NULL); |
| } |
| |
| |
| bool |
| gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) |
| { |
| if (!type_check (c, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (c, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 1, BT_INTEGER) |
| || !kind_value_check (status, 1, gfc_default_integer_kind) |
| || !scalar_check (status, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fgetput (gfc_expr *c) |
| { |
| return gfc_check_fgetput_sub (c, NULL); |
| } |
| |
| |
| bool |
| gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (offset, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (offset, 1)) |
| return false; |
| |
| if (!type_check (whence, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (whence, 2)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 3, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (status, 3, 4)) |
| return false; |
| |
| if (!scalar_check (status, 3)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| |
| bool |
| gfc_check_fstat (gfc_expr *unit, gfc_expr *array) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (array, 1, BT_INTEGER) |
| || !kind_value_check (unit, 0, gfc_default_integer_kind)) |
| return false; |
| |
| if (!array_check (array, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (array, 1, BT_INTEGER) |
| || !kind_value_check (array, 1, gfc_default_integer_kind)) |
| return false; |
| |
| if (!array_check (array, 1)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER) |
| || !kind_value_check (status, 2, gfc_default_integer_kind)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ftell (gfc_expr *unit) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) |
| { |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (offset, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (offset, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_stat (gfc_expr *name, gfc_expr *array) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (array, 1, BT_INTEGER) |
| || !kind_value_check (array, 1, gfc_default_integer_kind)) |
| return false; |
| |
| if (!array_check (array, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!type_check (array, 1, BT_INTEGER) |
| || !kind_value_check (array, 1, gfc_default_integer_kind)) |
| return false; |
| |
| if (!array_check (array, 1)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER) |
| || !kind_value_check (array, 1, gfc_default_integer_kind)) |
| return false; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) |
| { |
| mpz_t nelems; |
| |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (!coarray_check (coarray, 0)) |
| return false; |
| |
| if (sub->rank != 1) |
| { |
| gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", |
| gfc_current_intrinsic_arg[1]->name, &sub->where); |
| return false; |
| } |
| |
| if (gfc_array_size (sub, &nelems)) |
| { |
| int corank = gfc_get_corank (coarray); |
| |
| if (mpz_cmp_ui (nelems, corank) != 0) |
| { |
| gfc_error ("The number of array elements of the SUB argument to " |
| "IMAGE_INDEX at %L shall be %d (corank) not %d", |
| &sub->where, corank, (int) mpz_get_si (nelems)); |
| mpz_clear (nelems); |
| return false; |
| } |
| mpz_clear (nelems); |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) |
| { |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (distance) |
| { |
| if (!type_check (distance, 0, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("DISTANCE", distance)) |
| return false; |
| |
| if (!scalar_check (distance, 0)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " |
| "NUM_IMAGES at %L", &distance->where)) |
| return false; |
| } |
| |
| if (failed) |
| { |
| if (!type_check (failed, 1, BT_LOGICAL)) |
| return false; |
| |
| if (!scalar_check (failed, 1)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " |
| "NUM_IMAGES at %L", &failed->where)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_team_number (gfc_expr *team) |
| { |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (team) |
| { |
| if (team->ts.type != BT_DERIVED |
| || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV |
| || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) |
| { |
| gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " |
| "shall be of type TEAM_TYPE", &team->where); |
| return false; |
| } |
| } |
| else |
| return true; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) |
| { |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (coarray == NULL && dim == NULL && distance == NULL) |
| return true; |
| |
| if (dim != NULL && coarray == NULL) |
| { |
| gfc_error ("DIM argument without COARRAY argument not allowed for " |
| "THIS_IMAGE intrinsic at %L", &dim->where); |
| return false; |
| } |
| |
| if (distance && (coarray || dim)) |
| { |
| gfc_error ("The DISTANCE argument may not be specified together with the " |
| "COARRAY or DIM argument in intrinsic at %L", |
| &distance->where); |
| return false; |
| } |
| |
| /* Assume that we have "this_image (distance)". */ |
| if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) |
| { |
| if (dim) |
| { |
| gfc_error ("Unexpected DIM argument with noncoarray argument at %L", |
| &coarray->where); |
| return false; |
| } |
| distance = coarray; |
| } |
| |
| if (distance) |
| { |
| if (!type_check (distance, 2, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("DISTANCE", distance)) |
| return false; |
| |
| if (!scalar_check (distance, 2)) |
| return false; |
| |
| if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " |
| "THIS_IMAGE at %L", &distance->where)) |
| return false; |
| |
| return true; |
| } |
| |
| if (!coarray_check (coarray, 0)) |
| return false; |
| |
| if (dim != NULL) |
| { |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_corank_check (dim, coarray)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| /* Calculate the sizes for transfer, used by gfc_check_transfer and also |
| by gfc_simplify_transfer. Return false if we cannot do so. */ |
| |
| bool |
| gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, |
| size_t *source_size, size_t *result_size, |
| size_t *result_length_p) |
| { |
| size_t result_elt_size; |
| |
| if (source->expr_type == EXPR_FUNCTION) |
| return false; |
| |
| if (size && size->expr_type != EXPR_CONSTANT) |
| return false; |
| |
| /* Calculate the size of the source. */ |
| if (!gfc_target_expr_size (source, source_size)) |
| return false; |
| |
| /* Determine the size of the element. */ |
| if (!gfc_element_size (mold, &result_elt_size)) |
| return false; |
| |
| /* If the storage size of SOURCE is greater than zero and MOLD is an array, |
| * a scalar with the type and type parameters of MOLD shall not have a |
| * storage size equal to zero. |
| * If MOLD is a scalar and SIZE is absent, the result is a scalar. |
| * If MOLD is an array and SIZE is absent, the result is an array and of |
| * rank one. Its size is as small as possible such that its physical |
| * representation is not shorter than that of SOURCE. |
| * If SIZE is present, the result is an array of rank one and size SIZE. |
| */ |
| if (result_elt_size == 0 && *source_size > 0 && !size |
| && mold->expr_type == EXPR_ARRAY) |
| { |
| gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an " |
| "array and shall not have storage size 0 when %<SOURCE%> " |
| "argument has size greater than 0", &mold->where); |
| return false; |
| } |
| |
| if (result_elt_size == 0 && *source_size == 0 && !size) |
| { |
| *result_size = 0; |
| if (result_length_p) |
| *result_length_p = 0; |
| return true; |
| } |
| |
| if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank)) |
| || size) |
| { |
| int result_length; |
| |
| if (size) |
| result_length = (size_t)mpz_get_ui (size->value.integer); |
| else |
| { |
| result_length = *source_size / result_elt_size; |
| if (result_length * result_elt_size < *source_size) |
| result_length += 1; |
| } |
| |
| *result_size = result_length * result_elt_size; |
| if (result_length_p) |
| *result_length_p = result_length; |
| } |
| else |
| *result_size = result_elt_size; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) |
| { |
| size_t source_size; |
| size_t result_size; |
| |
| /* SOURCE shall be a scalar or array of any type. */ |
| if (source->ts.type == BT_PROCEDURE |
| && source->symtree->n.sym->attr.subroutine == 1) |
| { |
| gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L " |
| "must not be a %s", &source->where, |
| gfc_basic_typename (source->ts.type)); |
| return false; |
| } |
| |
| /* MOLD shall be a scalar or array of any type. */ |
| if (mold->ts.type == BT_PROCEDURE |
| && mold->symtree->n.sym->attr.subroutine == 1) |
| { |
| gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L " |
| "must not be a %s", &mold->where, |
| gfc_basic_typename (mold->ts.type)); |
| return false; |
| } |
| |
| if (mold->ts.type == BT_HOLLERITH) |
| { |
| gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be" |
| " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); |
| return false; |
| } |
| |
| /* SIZE (optional) shall be an integer scalar. The corresponding actual |
| argument shall not be an optional dummy argument. */ |
| if (size != NULL) |
| { |
| if (!type_check (size, 2, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (size, 2)) |
| return false; |
| |
| if (!nonoptional_check (size, 2)) |
| return false; |
| } |
| |
| if (!warn_surprising) |
| return true; |
| |
| /* If we can't calculate the sizes, we cannot check any more. |
| Return true for that case. */ |
| |
| if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, |
| &result_size, NULL)) |
| return true; |
| |
| if (source_size < result_size) |
| gfc_warning (OPT_Wsurprising, |
| "Intrinsic TRANSFER at %L has partly undefined result: " |
| "source size %ld < result size %ld", &source->where, |
| (long) source_size, (long) result_size); |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_transpose (gfc_expr *matrix) |
| { |
| if (!rank_check (matrix, 0, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_rank_check (dim, array, 0)) |
| return false; |
| |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) |
| { |
| if (flag_coarray == GFC_FCOARRAY_NONE) |
| { |
| gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
| return false; |
| } |
| |
| if (!coarray_check (coarray, 0)) |
| return false; |
| |
| if (dim != NULL) |
| { |
| if (!dim_check (dim, 1, false)) |
| return false; |
| |
| if (!dim_corank_check (dim, coarray)) |
| return false; |
| } |
| |
| if (!kind_check (kind, 2, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) |
| { |
| mpz_t vector_size; |
| |
| if (!rank_check (vector, 0, 1)) |
| return false; |
| |
| if (!array_check (mask, 1)) |
| return false; |
| |
| if (!type_check (mask, 1, BT_LOGICAL)) |
| return false; |
| |
| if (!same_type_check (vector, 0, field, 2)) |
| return false; |
| |
| if (mask->expr_type == EXPR_ARRAY |
| && gfc_array_size (vector, &vector_size)) |
| { |
| int mask_true_count = 0; |
| gfc_constructor *mask_ctor; |
| mask_ctor = gfc_constructor_first (mask->value.constructor); |
| while (mask_ctor) |
| { |
| if (mask_ctor->expr->expr_type != EXPR_CONSTANT) |
| { |
| mask_true_count = 0; |
| break; |
| } |
| |
| if (mask_ctor->expr->value.logical) |
| mask_true_count++; |
| |
| mask_ctor = gfc_constructor_next (mask_ctor); |
| } |
| |
| if (mpz_get_si (vector_size) < mask_true_count) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must " |
| "provide at least as many elements as there " |
| "are .TRUE. values in %qs (%ld/%d)", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &vector->where, gfc_current_intrinsic_arg[1]->name, |
| mpz_get_si (vector_size), mask_true_count); |
| return false; |
| } |
| |
| mpz_clear (vector_size); |
| } |
| |
| if (mask->rank != field->rank && field->rank != 0) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must have " |
| "the same rank as %qs or be a scalar", |
| gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, |
| &field->where, gfc_current_intrinsic_arg[1]->name); |
| return false; |
| } |
| |
| if (mask->rank == field->rank) |
| { |
| int i; |
| for (i = 0; i < field->rank; i++) |
| if (! identical_dimen_shape (mask, i, field, i)) |
| { |
| gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " |
| "must have identical shape.", |
| gfc_current_intrinsic_arg[2]->name, |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &field->where); |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) |
| { |
| if (!type_check (x, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!same_type_check (x, 0, y, 1)) |
| return false; |
| |
| if (z != NULL && !type_check (z, 2, BT_LOGICAL)) |
| return false; |
| |
| if (!kind_check (kind, 3, BT_INTEGER)) |
| return false; |
| if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " |
| "with KIND argument at %L", |
| gfc_current_intrinsic, &kind->where)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_trim (gfc_expr *x) |
| { |
| if (!type_check (x, 0, BT_CHARACTER)) |
| return false; |
| |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ttynam (gfc_expr *unit) |
| { |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /************* Check functions for intrinsic subroutines *************/ |
| |
| bool |
| gfc_check_cpu_time (gfc_expr *time) |
| { |
| if (!scalar_check (time, 0)) |
| return false; |
| |
| if (!type_check (time, 0, BT_REAL)) |
| return false; |
| |
| if (!variable_check (time, 0, false)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, |
| gfc_expr *zone, gfc_expr *values) |
| { |
| if (date != NULL) |
| { |
| if (!type_check (date, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (date, 0, gfc_default_character_kind)) |
| return false; |
| if (!scalar_check (date, 0)) |
| return false; |
| if (!variable_check (date, 0, false)) |
| return false; |
| } |
| |
| if (time != NULL) |
| { |
| if (!type_check (time, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (time, 1, gfc_default_character_kind)) |
| return false; |
| if (!scalar_check (time, 1)) |
| return false; |
| if (!variable_check (time, 1, false)) |
| return false; |
| } |
| |
| if (zone != NULL) |
| { |
| if (!type_check (zone, 2, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (zone, 2, gfc_default_character_kind)) |
| return false; |
| if (!scalar_check (zone, 2)) |
| return false; |
| if (!variable_check (zone, 2, false)) |
| return false; |
| } |
| |
| if (values != NULL) |
| { |
| if (!type_check (values, 3, BT_INTEGER)) |
| return false; |
| if (!array_check (values, 3)) |
| return false; |
| if (!rank_check (values, 3, 1)) |
| return false; |
| if (!variable_check (values, 3, false)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| 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)) |
| return false; |
| |
| if (!type_check (frompos, 1, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (len, 2, BT_INTEGER)) |
| return false; |
| |
| if (!same_type_check (from, 0, to, 3)) |
| return false; |
| |
| if (!variable_check (to, 3, false)) |
| return false; |
| |
| if (!type_check (topos, 4, BT_INTEGER)) |
| return false; |
| |
| if (!nonnegative_check ("frompos", frompos)) |
| return false; |
| |
| if (!nonnegative_check ("topos", topos)) |
| return false; |
| |
| if (!nonnegative_check ("len", len)) |
| return false; |
| |
| if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) |
| return false; |
| |
| if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Check the arguments for RANDOM_INIT. */ |
| |
| bool |
| gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct) |
| { |
| if (!type_check (repeatable, 0, BT_LOGICAL)) |
| return false; |
| |
| if (!scalar_check (repeatable, 0)) |
| return false; |
| |
| if (!type_check (image_distinct, 1, BT_LOGICAL)) |
| return false; |
| |
| if (!scalar_check (image_distinct, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_random_number (gfc_expr *harvest) |
| { |
| if (!type_check (harvest, 0, BT_REAL)) |
| return false; |
| |
| if (!variable_check (harvest, 0, false)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) |
| { |
| unsigned int nargs = 0, seed_size; |
| locus *where = NULL; |
| mpz_t put_size, get_size; |
| |
| /* Keep the number of bytes in sync with master_state in |
| libgfortran/intrinsics/random.c. +1 due to the integer p which is |
| part of the state too. */ |
| seed_size = 128 / gfc_default_integer_kind + 1; |
| |
| if (size != NULL) |
| { |
| if (size->expr_type != EXPR_VARIABLE |
| || !size->symtree->n.sym->attr.optional) |
| nargs++; |
| |
| if (!scalar_check (size, 0)) |
| return false; |
| |
| if (!type_check (size, 0, BT_INTEGER)) |
| return false; |
| |
| if (!variable_check (size, 0, false)) |
| return false; |
| |
| if (!kind_value_check (size, 0, gfc_default_integer_kind)) |
| return false; |
| } |
| |
| if (put != NULL) |
| { |
| if (put->expr_type != EXPR_VARIABLE |
| || !put->symtree->n.sym->attr.optional) |
| { |
| nargs++; |
| where = &put->where; |
| } |
| |
| if (!array_check (put, 1)) |
| return false; |
| |
| if (!rank_check (put, 1, 1)) |
| return false; |
| |
| if (!type_check (put, 1, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (put, 1, gfc_default_integer_kind)) |
| return false; |
| |
| if (gfc_array_size (put, &put_size) |
| && mpz_get_ui (put_size) < seed_size) |
| gfc_error ("Size of %qs argument of %qs intrinsic at %L " |
| "too small (%i/%i)", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| where, (int) mpz_get_ui (put_size), seed_size); |
| } |
| |
| if (get != NULL) |
| { |
| if (get->expr_type != EXPR_VARIABLE |
| || !get->symtree->n.sym->attr.optional) |
| { |
| nargs++; |
| where = &get->where; |
| } |
| |
| if (!array_check (get, 2)) |
| return false; |
| |
| if (!rank_check (get, 2, 1)) |
| return false; |
| |
| if (!type_check (get, 2, BT_INTEGER)) |
| return false; |
| |
| if (!variable_check (get, 2, false)) |
| return false; |
| |
| if (!kind_value_check (get, 2, gfc_default_integer_kind)) |
| return false; |
| |
| if (gfc_array_size (get, &get_size) |
| && mpz_get_ui (get_size) < seed_size) |
| gfc_error ("Size of %qs argument of %qs intrinsic at %L " |
| "too small (%i/%i)", |
| gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, |
| where, (int) mpz_get_ui (get_size), seed_size); |
| } |
| |
| /* RANDOM_SEED may not have more than one non-optional argument. */ |
| if (nargs > 1) |
| gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where); |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_fe_runtime_error (gfc_actual_arglist *a) |
| { |
| gfc_expr *e; |
| size_t len, i; |
| int num_percent, nargs; |
| |
| e = a->expr; |
| if (e->expr_type != EXPR_CONSTANT) |
| return true; |
| |
| len = e->value.character.length; |
| if (e->value.character.string[len-1] != '\0') |
| gfc_internal_error ("fe_runtime_error string must be null terminated"); |
| |
| num_percent = 0; |
| for (i=0; i<len-1; i++) |
| if (e->value.character.string[i] == '%') |
| num_percent ++; |
| |
| nargs = 0; |
| for (; a; a = a->next) |
| nargs ++; |
| |
| if (nargs -1 != num_percent) |
| gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)", |
| nargs, num_percent++); |
| |
| return true; |
| } |
| |
| bool |
| gfc_check_second_sub (gfc_expr *time) |
| { |
| if (!scalar_check (time, 0)) |
| return false; |
| |
| if (!type_check (time, 0, BT_REAL)) |
| return false; |
| |
| if (!kind_value_check (time, 0, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer |
| variables in Fortran 95. In Fortran 2003 and later, they can be of any |
| kind, and COUNT_RATE can be of type real. Note, count, count_rate, and |
| count_max are all optional arguments */ |
| |
| bool |
| gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, |
| gfc_expr *count_max) |
| { |
| if (count != NULL) |
| { |
| if (!scalar_check (count, 0)) |
| return false; |
| |
| if (!type_check (count, 0, BT_INTEGER)) |
| return false; |
| |
| if (count->ts.kind != gfc_default_integer_kind |
| && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to " |
| "SYSTEM_CLOCK at %L has non-default kind", |
| &count->where)) |
| return false; |
| |
| if (!variable_check (count, 0, false)) |
| return false; |
| } |
| |
| if (count_rate != NULL) |
| { |
| if (!scalar_check (count_rate, 1)) |
| return false; |
| |
| if (!variable_check (count_rate, 1, false)) |
| return false; |
| |
| if (count_rate->ts.type == BT_REAL) |
| { |
| if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to " |
| "SYSTEM_CLOCK at %L", &count_rate->where)) |
| return false; |
| } |
| else |
| { |
| if (!type_check (count_rate, 1, BT_INTEGER)) |
| return false; |
| |
| if (count_rate->ts.kind != gfc_default_integer_kind |
| && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to " |
| "SYSTEM_CLOCK at %L has non-default kind", |
| &count_rate->where)) |
| return false; |
| } |
| |
| } |
| |
| if (count_max != NULL) |
| { |
| if (!scalar_check (count_max, 2)) |
| return false; |
| |
| if (!type_check (count_max, 2, BT_INTEGER)) |
| return false; |
| |
| if (count_max->ts.kind != gfc_default_integer_kind |
| && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to " |
| "SYSTEM_CLOCK at %L has non-default kind", |
| &count_max->where)) |
| return false; |
| |
| if (!variable_check (count_max, 2, false)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_irand (gfc_expr *x) |
| { |
| if (x == NULL) |
| return true; |
| |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| if (!type_check (x, 0, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (x, 0, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) |
| { |
| if (!scalar_check (seconds, 0)) |
| return false; |
| if (!type_check (seconds, 0, BT_INTEGER)) |
| return false; |
| |
| if (!int_or_proc_check (handler, 1)) |
| return false; |
| if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!scalar_check (status, 2)) |
| return false; |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| if (!kind_value_check (status, 2, gfc_default_integer_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_rand (gfc_expr *x) |
| { |
| if (x == NULL) |
| return true; |
| |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| if (!type_check (x, 0, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (x, 0, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_srand (gfc_expr *x) |
| { |
| if (!scalar_check (x, 0)) |
| return false; |
| |
| if (!type_check (x, 0, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (x, 0, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) |
| { |
| if (!scalar_check (time, 0)) |
| return false; |
| if (!type_check (time, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (result, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (result, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dtime_etime (gfc_expr *x) |
| { |
| if (!array_check (x, 0)) |
| return false; |
| |
| if (!rank_check (x, 0, 1)) |
| return false; |
| |
| if (!variable_check (x, 0, false)) |
| return false; |
| |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| |
| if (!kind_value_check (x, 0, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) |
| { |
| if (!array_check (values, 0)) |
| return false; |
| |
| if (!rank_check (values, 0, 1)) |
| return false; |
| |
| if (!variable_check (values, 0, false)) |
| return false; |
| |
| if (!type_check (values, 0, BT_REAL)) |
| return false; |
| |
| if (!kind_value_check (values, 0, 4)) |
| return false; |
| |
| if (!scalar_check (time, 1)) |
| return false; |
| |
| if (!type_check (time, 1, BT_REAL)) |
| return false; |
| |
| if (!kind_value_check (time, 1, 4)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_fdate_sub (gfc_expr *date) |
| { |
| if (!type_check (date, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (date, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_gerror (gfc_expr *msg) |
| { |
| if (!type_check (msg, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (msg, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) |
| { |
| if (!type_check (cwd, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (cwd, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!scalar_check (status, 1)) |
| return false; |
| |
| if (!type_check (status, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_getarg (gfc_expr *pos, gfc_expr *value) |
| { |
| if (!type_check (pos, 0, BT_INTEGER)) |
| return false; |
| |
| if (pos->ts.kind > gfc_default_integer_kind) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " |
| "not wider than the default kind (%d)", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &pos->where, gfc_default_integer_kind); |
| return false; |
| } |
| |
| if (!type_check (value, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (value, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_getlog (gfc_expr *msg) |
| { |
| if (!type_check (msg, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (msg, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_exit (gfc_expr *status) |
| { |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (status, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_flush (gfc_expr *unit) |
| { |
| if (unit == NULL) |
| return true; |
| |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_free (gfc_expr *i) |
| { |
| if (!type_check (i, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (i, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_hostnm (gfc_expr *name) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!scalar_check (status, 1)) |
| return false; |
| |
| if (!type_check (status, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_itime_idate (gfc_expr *values) |
| { |
| if (!array_check (values, 0)) |
| return false; |
| |
| if (!rank_check (values, 0, 1)) |
| return false; |
| |
| if (!variable_check (values, 0, false)) |
| return false; |
| |
| if (!type_check (values, 0, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (values, 0, gfc_default_integer_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) |
| { |
| if (!type_check (time, 0, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (time, 0, gfc_default_integer_kind)) |
| return false; |
| |
| if (!scalar_check (time, 0)) |
| return false; |
| |
| if (!array_check (values, 1)) |
| return false; |
| |
| if (!rank_check (values, 1, 1)) |
| return false; |
| |
| if (!variable_check (values, 1, false)) |
| return false; |
| |
| if (!type_check (values, 1, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (values, 1, gfc_default_integer_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) |
| { |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!type_check (name, 1, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 1, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_is_contiguous (gfc_expr *array) |
| { |
| if (!array_check (array, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| |
| bool |
| gfc_check_isatty (gfc_expr *unit) |
| { |
| if (unit == NULL) |
| return false; |
| |
| if (!type_check (unit, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (unit, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_isnan (gfc_expr *x) |
| { |
| if (!type_check (x, 0, BT_REAL)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_perror (gfc_expr *string) |
| { |
| if (!type_check (string, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (string, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_umask (gfc_expr *mask) |
| { |
| if (!type_check (mask, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (mask, 0)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) |
| { |
| if (!type_check (mask, 0, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (mask, 0)) |
| return false; |
| |
| if (old == NULL) |
| return true; |
| |
| if (!scalar_check (old, 1)) |
| return false; |
| |
| if (!type_check (old, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_unlink (gfc_expr *name) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) |
| { |
| if (!type_check (name, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (name, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!scalar_check (status, 1)) |
| return false; |
| |
| if (!type_check (status, 1, BT_INTEGER)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_signal (gfc_expr *number, gfc_expr *handler) |
| { |
| if (!scalar_check (number, 0)) |
| return false; |
| if (!type_check (number, 0, BT_INTEGER)) |
| return false; |
| |
| if (!int_or_proc_check (handler, 1)) |
| return false; |
| if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) |
| { |
| if (!scalar_check (number, 0)) |
| return false; |
| if (!type_check (number, 0, BT_INTEGER)) |
| return false; |
| |
| if (!int_or_proc_check (handler, 1)) |
| return false; |
| if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) |
| return false; |
| |
| if (status == NULL) |
| return true; |
| |
| if (!type_check (status, 2, BT_INTEGER)) |
| return false; |
| if (!scalar_check (status, 2)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) |
| { |
| if (!type_check (cmd, 0, BT_CHARACTER)) |
| return false; |
| if (!kind_value_check (cmd, 0, gfc_default_character_kind)) |
| return false; |
| |
| if (!scalar_check (status, 1)) |
| return false; |
| |
| if (!type_check (status, 1, BT_INTEGER)) |
| return false; |
| |
| if (!kind_value_check (status, 1, gfc_default_integer_kind)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* This is used for the GNU intrinsics AND, OR and XOR. */ |
| bool |
| gfc_check_and (gfc_expr *i, gfc_expr *j) |
| { |
| if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or LOGICAL", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &i->where); |
| return false; |
| } |
| |
| if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " |
| "or LOGICAL", gfc_current_intrinsic_arg[1]->name, |
| gfc_current_intrinsic, &j->where); |
| return false; |
| } |
| |
| if (i->ts.type != j->ts.type) |
| { |
| gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " |
| "have the same type", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &j->where); |
| return false; |
| } |
| |
| if (!scalar_check (i, 0)) |
| return false; |
| |
| if (!scalar_check (j, 1)) |
| return false; |
| |
| if (!boz_args_check (i, j)) |
| return false; |
| |
| if (i->is_boz) i->ts.kind = j->ts.kind; |
| if (j->is_boz) j->ts.kind = i->ts.kind; |
| |
| return true; |
| } |
| |
| |
| bool |
| gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) |
| { |
| |
| if (a->expr_type == EXPR_NULL) |
| { |
| gfc_error ("Intrinsic function NULL at %L cannot be an actual " |
| "argument to STORAGE_SIZE, because it returns a " |
| "disassociated pointer", &a->where); |
| return false; |
| } |
| |
| if (a->ts.type == BT_ASSUMED) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", |
| gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, |
| &a->where); |
| return false; |
| } |
| |
| if (a->ts.type == BT_PROCEDURE) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " |
| "procedure", gfc_current_intrinsic_arg[0]->name, |
| gfc_current_intrinsic, &a->where); |
| return false; |
| } |
| |
| if (kind == NULL) |
| return true; |
| |
| if (!type_check (kind, 1, BT_INTEGER)) |
| return false; |
| |
| if (!scalar_check (kind, 1)) |
| return false; |
| |
| if (kind->expr_type != EXPR_CONSTANT) |
| { |
| gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", |
| gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, |
| &kind->where); |
| return false; |
| } |
| |
| return true; |
| } |