X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fcheck.c;h=afeb653a5a8f1f69a7d58c728abc2668286d464f;hp=6a5c263ed50283ca1df7df053c2c7559838dfcf5;hb=140b44efbc2f0035cbfd23e43d97ae9ffc00c122;hpb=f1d241cc353f610b130907dbc3a58ab209a326c2 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6a5c263ed50..afeb653a5a8 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -32,6 +32,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "intrinsic.h" #include "constructor.h" +#include "target-memory.h" /* Make sure an expression is a scalar. */ @@ -43,7 +44,8 @@ scalar_check (gfc_expr *e, int n) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } @@ -58,8 +60,8 @@ type_check (gfc_expr *e, int n, bt type) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where, - gfc_basic_typename (type)); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, gfc_basic_typename (type)); return FAILURE; } @@ -86,7 +88,8 @@ numeric_check (gfc_expr *e, int n) } gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } @@ -100,7 +103,7 @@ int_or_real_check (gfc_expr *e, int n) if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[n], + "or REAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -117,7 +120,24 @@ real_or_complex_check (gfc_expr *e, int n) if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL " - "or COMPLEX", gfc_current_intrinsic_arg[n], + "or COMPLEX", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Check that an expression is INTEGER or PROCEDURE. */ + +static gfc_try +int_or_proc_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -146,7 +166,7 @@ kind_check (gfc_expr *k, int n, bt type) if (k->expr_type != EXPR_CONSTANT) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &k->where); return FAILURE; } @@ -174,7 +194,7 @@ double_check (gfc_expr *d, int n) if (d->ts.kind != gfc_default_double_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be double " - "precision", gfc_current_intrinsic_arg[n], + "precision", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &d->where); return FAILURE; } @@ -183,30 +203,27 @@ double_check (gfc_expr *d, int n) } -/* Check whether an expression is a coarray (without array designator). */ - -static bool -is_coarray (gfc_expr *e) +static gfc_try +coarray_check (gfc_expr *e, int n) { - bool coarray = false; - gfc_ref *ref; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - coarray = e->symtree->n.sym->attr.codimension; + 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 SUCCESS; + } - for (ref = e->ref; ref; ref = ref->next) + if (!gfc_is_coarray (e)) { - if (ref->type == REF_COMPONENT) - coarray = ref->u.c.component->attr.codimension; - else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 - || ref->u.ar.codimen != 0) - coarray = false; + gfc_error ("Expected coarray variable as '%s' argument to the %s " + "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; } - return coarray; -} + return SUCCESS; +} /* Make sure the expression is a logical array. */ @@ -217,8 +234,8 @@ logical_array_check (gfc_expr *array, int n) if (array->ts.type != BT_LOGICAL || array->rank == 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical " - "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic, - &array->where); + "array", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &array->where); return FAILURE; } @@ -231,11 +248,20 @@ logical_array_check (gfc_expr *array, int n) static gfc_try 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 SUCCESS; + } + if (e->rank != 0) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } @@ -264,11 +290,11 @@ nonnegative_check (const char *arg, gfc_expr *expr) /* If expr2 is constant, then check that the value is less than - bit_size(expr1). */ + (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ static gfc_try less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, - gfc_expr *expr2) + gfc_expr *expr2, bool or_equal) { int i2, i3; @@ -276,11 +302,40 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, { gfc_extract_int (expr2, &i2); i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); - if (i2 >= gfc_integer_kinds[i3].bit_size) + + /* For ISHFT[C], check that |shift| <= bit_size(i). */ + if (arg2 == NULL) { - gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", - arg2, &expr2->where, arg1); - return FAILURE; + 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('%s')", + &expr2->where, arg1); + return FAILURE; + } + } + + if (or_equal) + { + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than " + "or equal to BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } + } + else + { + if (i2 >= gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } } } @@ -288,6 +343,31 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, } +/* If expr is constant, then check that the value is less than or equal + to the bit_size of the kind k. */ + +static gfc_try +less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) +{ + int i, val; + + if (expr->expr_type != EXPR_CONSTANT) + return SUCCESS; + + i = gfc_validate_kind (BT_INTEGER, k, false); + gfc_extract_int (expr, &val); + + if (val > gfc_integer_kinds[i].bit_size) + { + gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of " + "INTEGER(KIND=%d)", arg, &expr->where, k); + return FAILURE; + } + + return SUCCESS; +} + + /* If expr2 and expr3 are constants, then check that the value is less than or equal to bit_size(expr1). */ @@ -324,8 +404,9 @@ same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " - "and kind as '%s'", gfc_current_intrinsic_arg[m], - gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]); + "and kind as '%s'", gfc_current_intrinsic_arg[m]->name, + gfc_current_intrinsic, &f->where, + gfc_current_intrinsic_arg[n]->name); return FAILURE; } @@ -340,7 +421,7 @@ rank_check (gfc_expr *e, int n, int rank) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, rank); return FAILURE; @@ -355,7 +436,7 @@ nonoptional_check (gfc_expr *e, int n) if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); } @@ -365,6 +446,26 @@ nonoptional_check (gfc_expr *e, int n) } +/* Check for ALLOCATABLE attribute. */ + +static gfc_try +allocatable_check (gfc_expr *e, int n) +{ + symbol_attribute attr; + + attr = gfc_variable_attr (e, NULL); + if (!attr.allocatable) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return FAILURE; + } + + return SUCCESS; +} + + /* Check that an expression has a particular kind. */ static gfc_try @@ -374,7 +475,7 @@ kind_value_check (gfc_expr *e, int n, int k) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, k); return FAILURE; @@ -384,25 +485,56 @@ kind_value_check (gfc_expr *e, int n, int k) /* Make sure an expression is a variable. */ static gfc_try -variable_check (gfc_expr *e, int n) +variable_check (gfc_expr *e, int n, bool allow_proc) { - if ((e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor != FL_PARAMETER) - || (e->expr_type == EXPR_FUNCTION - && e->symtree->n.sym->result == e->symtree->n.sym)) - return SUCCESS; + 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 ("'%s' argument of '%s' intrinsic at %L cannot be " + "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; + } + } if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.intent == INTENT_IN) + && e->symtree->n.sym->attr.flavor != FL_PARAMETER + && (allow_proc || !e->symtree->n.sym->attr.function)) + return SUCCESS; + + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function + && e->symtree->n.sym == e->symtree->n.sym->result) { - gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, - &e->where); - return FAILURE; + gfc_namespace *ns; + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (ns->proc_name == e->symtree->n.sym) + return SUCCESS; } gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -435,16 +567,17 @@ dim_check (gfc_expr *dim, int n, bool optional) static gfc_try dim_corank_check (gfc_expr *dim, gfc_expr *array) { - gfc_array_ref *ar; int corank; gcc_assert (array->expr_type == EXPR_VARIABLE); if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; + + if (array->ts.type == BT_CLASS) + return SUCCESS; - ar = gfc_find_array_ref (array); - corank = ar->as->corank; + corank = gfc_get_corank (array); if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, corank) > 0) @@ -473,12 +606,18 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) if (dim == NULL) return SUCCESS; - if (dim->expr_type != EXPR_CONSTANT - || (array->expr_type != EXPR_VARIABLE - && array->expr_type != EXPR_ARRAY)) + if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; - rank = array->rank; + if (array->ts.type == BT_CLASS) + return SUCCESS; + + 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; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); @@ -531,40 +670,69 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) 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.start->expr_type == EXPR_CONSTANT + && ra->u.ss.end->expr_type == EXPR_CONSTANT) + { + start_a = mpz_get_si (ra->u.ss.start->value.integer); + end_a = mpz_get_si (ra->u.ss.end->value.integer); + return end_a - start_a + 1; + } + else if (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 SUCCESS if they have or if the length cannot be determined. */ + returns SUCCESS if they have or if the length cannot be determined, + otherwise return FAILURE and raise a gfc_error. */ gfc_try gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) { long len_a, len_b; - len_a = len_b = -1; - - if (a->ts.u.cl && a->ts.u.cl->length - && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_a = 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)) - len_a = a->value.character.length; - else - return SUCCESS; - if (b->ts.u.cl && b->ts.u.cl->length - && b->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_b = mpz_get_si (b->ts.u.cl->length->value.integer); - else if (b->expr_type == EXPR_CONSTANT - && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL)) - len_b = b->value.character.length; - else - return SUCCESS; + len_a = gfc_var_strlen(a); + len_b = gfc_var_strlen(b); - if (len_a == len_b) + if (len_a == -1 || len_b == -1 || len_a == len_b) return SUCCESS; - - gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", - len_a, len_b, name, &a->where); - return FAILURE; + else + { + gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", + len_a, len_b, name, &a->where); + return FAILURE; + } } @@ -663,20 +831,11 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) gfc_try gfc_check_allocated (gfc_expr *array) { - symbol_attribute attr; - - if (variable_check (array, 0) == FAILURE) + if (variable_check (array, 0, false) == FAILURE) return FAILURE; - - attr = gfc_variable_attr (array, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &array->where); - return FAILURE; - } - + if (allocatable_check (array, 0) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -693,8 +852,8 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (a->ts.type != p->ts.type) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &p->where); return FAILURE; } @@ -740,11 +899,20 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (!attr1.pointer && !attr1.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return FAILURE; } + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (pointer)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &pointer->where); + return FAILURE; + } + /* Target argument is optional. */ if (target == NULL) return SUCCESS; @@ -758,15 +926,25 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) else { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " - "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &target->where); + "or target VARIABLE or FUNCTION", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &target->where); return FAILURE; } if (attr1.pointer && !attr2.pointer && !attr2.target) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " - "or a TARGET", gfc_current_intrinsic_arg[1], + "or a TARGET", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &target->where); + return FAILURE; + } + + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (target)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return FAILURE; } @@ -802,7 +980,7 @@ null_arg: gfc_try gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) { - /* gfc_notify_std would be a wast of time as the return value + /* 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) @@ -824,6 +1002,72 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x) } +static gfc_try +gfc_check_atomic (gfc_expr *atom, gfc_expr *value) +{ + 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 FAILURE; + } + + if (!gfc_expr_attr (atom).codimension) + { + gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " + "coarray or coindexed", &atom->where, gfc_current_intrinsic); + return FAILURE; + } + + if (atom->ts.type != value->ts.type) + { + gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall " + "have the same type at %L", gfc_current_intrinsic, + &value->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try +gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value) +{ + if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE) + return FAILURE; + + if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return FAILURE; + } + + return gfc_check_atomic (atom, value); +} + + +gfc_try +gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom) +{ + if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE) + return FAILURE; + + if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE) + { + gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &value->where); + return FAILURE; + } + + return gfc_check_atomic (atom, value); +} + + /* BESJN and BESYN functions. */ gfc_try @@ -831,6 +1075,14 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) { if (type_check (n, 0, BT_INTEGER) == FAILURE) return FAILURE; + if (n->expr_type == EXPR_CONSTANT) + { + int i; + gfc_extract_int (n, &i); + if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument " + "N at %L", &n->where) == FAILURE) + return FAILURE; + } if (type_check (x, 1, BT_REAL) == FAILURE) return FAILURE; @@ -839,6 +1091,47 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) } +/* Transformational version of the Bessel JN and YN functions. */ + +gfc_try +gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + if (type_check (n1, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (n1, 0) == FAILURE) + return FAILURE; + if (nonnegative_check("N1", n1) == FAILURE) + return FAILURE; + + if (type_check (n2, 1, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (n2, 1) == FAILURE) + return FAILURE; + if (nonnegative_check("N2", n2) == FAILURE) + return FAILURE; + + if (type_check (x, 2, BT_REAL) == FAILURE) + return FAILURE; + if (scalar_check (x, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + gfc_try gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { @@ -851,7 +1144,7 @@ gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) if (nonnegative_check ("pos", pos) == FAILURE) return FAILURE; - if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE) + if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE) return FAILURE; return SUCCESS; @@ -959,16 +1252,18 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) if (x->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " - "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "present if 'x' is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } if (y->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " - "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } @@ -984,23 +1279,13 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) gfc_try gfc_check_complex (gfc_expr *x, gfc_expr *y) { - if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &x->where); - return FAILURE; - } + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; if (scalar_check (x, 0) == FAILURE) return FAILURE; - if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); - return FAILURE; - } + if (int_or_real_check (y, 1) == FAILURE) + return FAILURE; if (scalar_check (y, 1) == FAILURE) return FAILURE; @@ -1068,7 +1353,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1], + 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])); @@ -1082,7 +1367,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1], + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return FAILURE; } @@ -1126,16 +1411,18 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) if (x->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " - "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "present if 'x' is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } if (y->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " - "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } } @@ -1183,7 +1470,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) default: gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector_a->where); return FAILURE; } @@ -1197,8 +1484,8 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) { gfc_error ("Different shape for arguments '%s' and '%s' at %L for " - "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &vector_a->where); + "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &vector_a->where); return FAILURE; } @@ -1216,7 +1503,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (x->ts.kind != gfc_default_real_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[0], + "real", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return FAILURE; } @@ -1224,7 +1511,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (y->ts.kind != gfc_default_real_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[1], + "real", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return FAILURE; } @@ -1234,6 +1521,48 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) gfc_try +gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (i->is_boz && j->is_boz) + { + gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal " + "constants", &i->where, &j->where); + return FAILURE; + } + + if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + if (type_check (shift, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("SHIFT", shift) == FAILURE) + return FAILURE; + + if (i->is_boz) + { + if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE) + return FAILURE; + i->ts.kind = j->ts.kind; + } + else + { + if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) + return FAILURE; + j->ts.kind = i->ts.kind; + } + + return SUCCESS; +} + + +gfc_try gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { @@ -1274,7 +1603,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1], + 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])); @@ -1288,7 +1617,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1], + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return FAILURE; } @@ -1308,16 +1637,17 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (gfc_check_conformance (shift, boundary, "arguments '%s' and '%s' for " "intrinsic %s", - gfc_current_intrinsic_arg[1], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic ) == FAILURE) return FAILURE; } else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have " - "rank %d or be a scalar", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &shift->where, array->rank - 1); + "rank %d or be a scalar", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &shift->where, array->rank - 1); return FAILURE; } } @@ -1332,7 +1662,7 @@ gfc_check_float (gfc_expr *a) return FAILURE; if ((a->ts.kind != gfc_default_integer_kind) - && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER" + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER " "kind argument to %s intrinsic at %L", gfc_current_intrinsic, &a->where) == FAILURE ) return FAILURE; @@ -1394,8 +1724,8 @@ gfc_check_fn_rc2008 (gfc_expr *a) if (a->ts.type == BT_COMPLEX && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' " "argument of '%s' intrinsic at %L", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &a->where) == FAILURE) + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where) == FAILURE) return FAILURE; return SUCCESS; @@ -1616,9 +1946,9 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, if (string->ts.kind != substring->ts.kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same " - "kind as '%s'", gfc_current_intrinsic_arg[1], + "kind as '%s'", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &substring->where, - gfc_current_intrinsic_arg[0]); + gfc_current_intrinsic_arg[0]->name); return FAILURE; } @@ -1676,6 +2006,9 @@ gfc_check_ishft (gfc_expr *i, gfc_expr *shift) || type_check (shift, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -1687,7 +2020,42 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) || type_check (shift, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE) + if (size != NULL) + { + int i2, i3; + + if (type_check (size, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE) + return FAILURE; + + 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 FAILURE; + } + + 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 FAILURE; + } + } + } + } + else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE) return FAILURE; return SUCCESS; @@ -1741,7 +2109,7 @@ gfc_check_kind (gfc_expr *x) if (x->ts.type == BT_DERIVED) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a " - "non-derived type", gfc_current_intrinsic_arg[0], + "non-derived type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return FAILURE; } @@ -1782,12 +2150,8 @@ gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) return FAILURE; } - if (!is_coarray (coarray)) - { - gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND " - "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); - return FAILURE; - } + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; if (dim != NULL) { @@ -1885,7 +2249,7 @@ gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) gfc_try gfc_check_loc (gfc_expr *expr) { - return variable_check (expr, 0); + return variable_check (expr, 0, true); } @@ -2073,7 +2437,7 @@ 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 ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return FAILURE; } @@ -2081,7 +2445,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[1], + "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &matrix_b->where); return FAILURE; } @@ -2105,8 +2469,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_error ("Different shape on dimension 1 for arguments '%s' " "and '%s' at %L for intrinsic matmul", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &matrix_a->where); + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return FAILURE; } break; @@ -2124,15 +2488,15 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_error ("Different shape on dimension 2 for argument '%s' and " "dimension 1 for argument '%s' at %L for intrinsic " - "matmul", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &matrix_a->where); + "matmul", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return FAILURE; } break; default: gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank " - "1 or 2", gfc_current_intrinsic_arg[0], + "1 or 2", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return FAILURE; } @@ -2188,8 +2552,8 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) if (m != NULL && gfc_check_conformance (a, m, "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic ) == FAILURE) return FAILURE; @@ -2242,8 +2606,8 @@ check_reduction (gfc_actual_arglist *ap) if (m != NULL && gfc_check_conformance (a, m, "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; @@ -2251,22 +2615,68 @@ check_reduction (gfc_actual_arglist *ap) } -gfc_try -gfc_check_minval_maxval (gfc_actual_arglist *ap) -{ - if (int_or_real_check (ap->expr, 0) == FAILURE - || array_check (ap->expr, 0) == FAILURE) +gfc_try +gfc_check_minval_maxval (gfc_actual_arglist *ap) +{ + if (int_or_real_check (ap->expr, 0) == FAILURE + || array_check (ap->expr, 0) == FAILURE) + return FAILURE; + + return check_reduction (ap); +} + + +gfc_try +gfc_check_product_sum (gfc_actual_arglist *ap) +{ + if (numeric_check (ap->expr, 0) == FAILURE + || array_check (ap->expr, 0) == FAILURE) + return FAILURE; + + return check_reduction (ap); +} + + +/* For IANY, IALL and IPARITY. */ + +gfc_try +gfc_check_mask (gfc_expr *i, gfc_expr *kind) +{ + int k; + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("I", i) == FAILURE) + return FAILURE; + + if (kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind) + gfc_extract_int (kind, &k); + else + k = gfc_default_integer_kind; + + if (less_than_bitsizekind ("I", i, k) == FAILURE) return FAILURE; - return check_reduction (ap); + return SUCCESS; } gfc_try -gfc_check_product_sum (gfc_actual_arglist *ap) +gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) { - if (numeric_check (ap->expr, 0) == FAILURE - || array_check (ap->expr, 0) == FAILURE) + if (ap->expr->ts.type != BT_INTEGER) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &ap->expr->where); + return FAILURE; + } + + if (array_check (ap->expr, 0) == FAILURE) return FAILURE; return check_reduction (ap); @@ -2290,31 +2700,45 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) gfc_try -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) { - symbol_attribute attr; + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; - if (variable_check (from, 0) == FAILURE) + if (type_check (j, 1, BT_INTEGER) == FAILURE) return FAILURE; - attr = gfc_variable_attr (from, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &from->where); - return FAILURE; - } + if (type_check (mask, 2, BT_INTEGER) == FAILURE) + return FAILURE; - if (variable_check (to, 0) == FAILURE) + if (same_type_check (i, 0, j, 1) == FAILURE) return FAILURE; - attr = gfc_variable_attr (to, NULL); - if (!attr.allocatable) + if (same_type_check (i, 0, mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +{ + if (variable_check (from, 0, false) == FAILURE) + return FAILURE; + if (allocatable_check (from, 0) == FAILURE) + return FAILURE; + + if (variable_check (to, 1, false) == FAILURE) + return FAILURE; + if (allocatable_check (to, 1) == FAILURE) + return FAILURE; + + if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &to->where); + gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " + "polymorphic if FROM is polymorphic", + &from->where); return FAILURE; } @@ -2324,8 +2748,8 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (to->rank != from->rank) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same rank %d/%d", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &to->where, from->rank, to->rank); return FAILURE; } @@ -2333,12 +2757,17 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (to->ts.kind != from->ts.kind) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " - "be of the same kind %d/%d", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "be of the same kind %d/%d", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &to->where, from->ts.kind, to->ts.kind); return FAILURE; } + /* CLASS arguments: Make sure the vtab of from is present. */ + if (to->ts.type == BT_CLASS) + gfc_find_derived_vtab (from->ts.u.derived); + return SUCCESS; } @@ -2352,6 +2781,16 @@ gfc_check_nearest (gfc_expr *x, gfc_expr *s) if (type_check (s, 1, BT_REAL) == FAILURE) return FAILURE; + 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 FAILURE; + } + } + return SUCCESS; } @@ -2367,6 +2806,21 @@ gfc_check_new_line (gfc_expr *a) gfc_try +gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) +{ + if (type_check (array, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +gfc_try gfc_check_null (gfc_expr *mold) { symbol_attribute attr; @@ -2374,15 +2828,30 @@ gfc_check_null (gfc_expr *mold) if (mold == NULL) return SUCCESS; - if (variable_check (mold, 0) == FAILURE) + if (variable_check (mold, 0, true) == FAILURE) return FAILURE; attr = gfc_variable_attr (mold, NULL); - if (!attr.pointer && !attr.proc_pointer) + if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0], + gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, " + "ALLOCATABLE or procedure pointer", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &mold->where); + return FAILURE; + } + + if (attr.allocatable + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with " + "allocatable MOLD at %L", &mold->where) == FAILURE) + return FAILURE; + + /* F2008, C1242. */ + if (gfc_is_coindexed (mold)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return FAILURE; } @@ -2402,8 +2871,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (gfc_check_conformance (array, mask, "arguments '%s' and '%s' for intrinsic '%s'", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; @@ -2456,8 +2925,9 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_error ("'%s' argument of '%s' intrinsic at %L must " "provide at least as many elements as there " "are .TRUE. values in '%s' (%ld/%d)", - gfc_current_intrinsic_arg[2],gfc_current_intrinsic, - &vector->where, gfc_current_intrinsic_arg[1], + 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 FAILURE; } @@ -2474,15 +2944,26 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_try +gfc_check_parity (gfc_expr *mask, gfc_expr *dim) +{ + if (type_check (mask, 0, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (array_check (mask, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, mask, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_precision (gfc_expr *x) { - if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type " - "REAL or COMPLEX", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &x->where); - return FAILURE; - } + if (real_or_complex_check (x, 0) == FAILURE) + return FAILURE; return SUCCESS; } @@ -2493,14 +2974,14 @@ gfc_check_present (gfc_expr *a) { gfc_symbol *sym; - if (variable_check (a, 0) == FAILURE) + if (variable_check (a, 0, true) == FAILURE) return FAILURE; sym = a->symtree->n.sym; if (!sym->attr.dummy) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a " - "dummy variable", gfc_current_intrinsic_arg[0], + "dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return FAILURE; } @@ -2508,8 +2989,9 @@ gfc_check_present (gfc_expr *a) if (!sym->attr.optional) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of " - "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "an OPTIONAL dummy variable", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } @@ -2521,10 +3003,12 @@ gfc_check_present (gfc_expr *a) 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_FULL + || (a->ref->u.ar.type == AR_ELEMENT + && a->ref->u.ar.as->rank == 0)))) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a " - "subobject of '%s'", gfc_current_intrinsic_arg[0], + "subobject of '%s'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, sym->name); return FAILURE; } @@ -2553,6 +3037,33 @@ gfc_check_range (gfc_expr *x) } +gfc_try +gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED) +{ + /* 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 + || !is_variable) + { + gfc_error ("The argument of the RANK intrinsic at %L must be a data " + "object", &a->where); + return FAILURE; + } + + return SUCCESS; +} + + /* real, float, sngl. */ gfc_try gfc_check_real (gfc_expr *a, gfc_expr *kind) @@ -2659,7 +3170,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (shape_size <= 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shape->where); return FAILURE; } @@ -2683,7 +3194,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (extent < 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L has " - "negative element (%d)", gfc_current_intrinsic_arg[1], + "negative element (%d)", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &e->where, extent); return FAILURE; } @@ -2723,7 +3235,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L " "has wrong number of elements (%d/%d)", - gfc_current_intrinsic_arg[3], + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, order_size, shape_size); return FAILURE; @@ -2741,7 +3253,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L " "has out-of-range dimension (%d)", - gfc_current_intrinsic_arg[3], + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return FAILURE; } @@ -2750,7 +3262,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid permutation of dimensions (dimension " - "'%d' duplicated)", gfc_current_intrinsic_arg[3], + "'%d' duplicated)", + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return FAILURE; } @@ -2802,32 +3315,36 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "must be of a derived type", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } if (!gfc_type_is_extensible (a->ts.u.derived)) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of an extensible type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "must be of an extensible type", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &b->where); + "must be of a derived type", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &b->where); return FAILURE; } if (!gfc_type_is_extensible (b->ts.u.derived)) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of an extensible type", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &b->where); + "must be of an extensible type", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &b->where); return FAILURE; } @@ -2920,21 +3437,45 @@ gfc_check_selected_int_kind (gfc_expr *r) gfc_try -gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) +gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { - if (p == NULL && r == NULL) + if (p == NULL && r == NULL + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with" + " neither 'P' nor 'R' argument at %L", + gfc_current_intrinsic_where) == FAILURE) + return FAILURE; + + if (p) { - gfc_error ("Missing arguments to %s intrinsic at %L", - gfc_current_intrinsic, gfc_current_intrinsic_where); + if (type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; - return FAILURE; + if (scalar_check (p, 0) == FAILURE) + return FAILURE; } - if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (r) + { + if (type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; - if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (scalar_check (r, 1) == FAILURE) + return FAILURE; + } + + if (radix) + { + if (type_check (radix, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (radix, 1) == FAILURE) + return FAILURE; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where) == FAILURE) + return FAILURE; + } return SUCCESS; } @@ -2954,7 +3495,7 @@ gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) gfc_try -gfc_check_shape (gfc_expr *source) +gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_array_ref *ar; @@ -2970,6 +3511,32 @@ gfc_check_shape (gfc_expr *source) return FAILURE; } + if (kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_shift (gfc_expr *i, gfc_expr *shift) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (shift, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("SHIFT", shift) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -3012,8 +3579,30 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_try -gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED) +gfc_check_sizeof (gfc_expr *arg) +{ + if (arg->ts.type == BT_PROCEDURE) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return FAILURE; + } + return SUCCESS; +} + + +gfc_try +gfc_check_c_sizeof (gfc_expr *arg) { + if (gfc_verify_c_interop (&arg->ts) != SUCCESS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be an " + "interoperable data entity", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return FAILURE; + } return SUCCESS; } @@ -3037,7 +3626,7 @@ gfc_check_sngl (gfc_expr *a) return FAILURE; if ((a->ts.kind != gfc_default_double_kind) - && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision" + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision " "REAL argument to %s intrinsic at %L", gfc_current_intrinsic, &a->where) == FAILURE) return FAILURE; @@ -3051,7 +3640,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) if (source->rank >= GFC_MAX_DIMENSIONS) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be less " - "than rank %d", gfc_current_intrinsic_arg[0], + "than rank %d", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); return FAILURE; @@ -3070,7 +3659,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) { gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid " - "dimension index", gfc_current_intrinsic_arg[1], + "dimension index", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &dim->where); return FAILURE; } @@ -3319,26 +3908,39 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) gfc_try gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) { + mpz_t nelems; + if (gfc_option.coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); return FAILURE; } - if (!is_coarray (coarray)) - { - gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX " - "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); - return FAILURE; - } + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; if (sub->rank != 1) { gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", - gfc_current_intrinsic_arg[1], &sub->where); + gfc_current_intrinsic_arg[1]->name, &sub->where); return FAILURE; } + if (gfc_array_size (sub, &nelems) == SUCCESS) + { + 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 FAILURE; + } + mpz_clear (nelems); + } + return SUCCESS; } @@ -3362,12 +3964,8 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) if (coarray == NULL) return SUCCESS; - if (!is_coarray (coarray)) - { - gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE " - "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); - return FAILURE; - } + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; if (dim != NULL) { @@ -3381,11 +3979,68 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) return SUCCESS; } +/* Calculate the sizes for transfer, used by gfc_check_transfer and also + by gfc_simplify_transfer. Return FAILURE if we cannot do so. */ + +gfc_try +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; + mpz_t tmp; + gfc_expr *mold_element; + + if (source->expr_type == EXPR_FUNCTION) + return FAILURE; + + /* Calculate the size of the source. */ + if (source->expr_type == EXPR_ARRAY + && gfc_array_size (source, &tmp) == FAILURE) + return FAILURE; + + *source_size = gfc_target_expr_size (source); + + mold_element = mold->expr_type == EXPR_ARRAY + ? gfc_constructor_first (mold->value.constructor)->expr + : mold; + + /* Determine the size of the element. */ + result_elt_size = gfc_target_expr_size (mold_element); + if (result_elt_size == 0) + return FAILURE; + + if (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 SUCCESS; +} + gfc_try -gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, - gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) +gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) { + size_t source_size; + size_t result_size; + if (mold->ts.type == BT_HOLLERITH) { gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s", @@ -3405,6 +4060,21 @@ gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, return FAILURE; } + if (!gfc_option.warn_surprising) + return SUCCESS; + + /* If we can't calculate the sizes, we cannot check any more. + Return SUCCESS for that case. */ + + if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, NULL) == FAILURE) + return SUCCESS; + + if (source_size < result_size) + gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " + "source size %ld < result size %ld", &source->where, + (long) source_size, (long) result_size); + return SUCCESS; } @@ -3451,12 +4121,8 @@ gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) return FAILURE; } - if (!is_coarray (coarray)) - { - gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND " - "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); - return FAILURE; - } + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; if (dim != NULL) { @@ -3516,8 +4182,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) gfc_error ("'%s' argument of '%s' intrinsic at %L must " "provide at least as many elements as there " "are .TRUE. values in '%s' (%ld/%d)", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &vector->where, gfc_current_intrinsic_arg[1], + 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 FAILURE; } @@ -3529,8 +4195,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have " "the same rank as '%s' or be a scalar", - gfc_current_intrinsic_arg[2], gfc_current_intrinsic, - &field->where, gfc_current_intrinsic_arg[1]); + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + &field->where, gfc_current_intrinsic_arg[1]->name); return FAILURE; } @@ -3542,8 +4208,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " "must have identical shape.", - gfc_current_intrinsic_arg[2], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &field->where); } } @@ -3625,7 +4291,7 @@ gfc_check_cpu_time (gfc_expr *time) if (type_check (time, 0, BT_REAL) == FAILURE) return FAILURE; - if (variable_check (time, 0) == FAILURE) + if (variable_check (time, 0, false) == FAILURE) return FAILURE; return SUCCESS; @@ -3644,7 +4310,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (date, 0) == FAILURE) return FAILURE; - if (variable_check (date, 0) == FAILURE) + if (variable_check (date, 0, false) == FAILURE) return FAILURE; } @@ -3656,7 +4322,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (time, 1) == FAILURE) return FAILURE; - if (variable_check (time, 1) == FAILURE) + if (variable_check (time, 1, false) == FAILURE) return FAILURE; } @@ -3668,7 +4334,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (zone, 2) == FAILURE) return FAILURE; - if (variable_check (zone, 2) == FAILURE) + if (variable_check (zone, 2, false) == FAILURE) return FAILURE; } @@ -3680,7 +4346,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (rank_check (values, 3, 1) == FAILURE) return FAILURE; - if (variable_check (values, 3) == FAILURE) + if (variable_check (values, 3, false) == FAILURE) return FAILURE; } @@ -3704,7 +4370,7 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, if (same_type_check (from, 0, to, 3) == FAILURE) return FAILURE; - if (variable_check (to, 3) == FAILURE) + if (variable_check (to, 3, false) == FAILURE) return FAILURE; if (type_check (topos, 4, BT_INTEGER) == FAILURE) @@ -3736,7 +4402,7 @@ gfc_check_random_number (gfc_expr *harvest) if (type_check (harvest, 0, BT_REAL) == FAILURE) return FAILURE; - if (variable_check (harvest, 0) == FAILURE) + if (variable_check (harvest, 0, false) == FAILURE) return FAILURE; return SUCCESS; @@ -3769,7 +4435,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (type_check (size, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (size, 0) == FAILURE) + if (variable_check (size, 0, false) == FAILURE) return FAILURE; if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE) @@ -3801,8 +4467,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) && mpz_get_ui (put_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where, - (int) mpz_get_ui (put_size), kiss_size); + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + where, (int) mpz_get_ui (put_size), kiss_size); } if (get != NULL) @@ -3823,7 +4489,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (type_check (get, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (get, 2) == FAILURE) + if (variable_check (get, 2, false) == FAILURE) return FAILURE; if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE) @@ -3833,8 +4499,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) && mpz_get_ui (get_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", - gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where, - (int) mpz_get_ui (get_size), kiss_size); + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + where, (int) mpz_get_ui (get_size), kiss_size); } /* RANDOM_SEED may not have more than one non-optional argument. */ @@ -3876,7 +4542,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count, 0) == FAILURE) + if (variable_check (count, 0, false) == FAILURE) return FAILURE; } @@ -3888,7 +4554,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count_rate, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count_rate, 1) == FAILURE) + if (variable_check (count_rate, 1, false) == FAILURE) return FAILURE; if (count != NULL @@ -3905,7 +4571,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count_max, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count_max, 2) == FAILURE) + if (variable_check (count_max, 2, false) == FAILURE) return FAILURE; if (count != NULL @@ -3945,18 +4611,11 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) { if (scalar_check (seconds, 0) == FAILURE) return FAILURE; - if (type_check (seconds, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -3965,10 +4624,8 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) if (scalar_check (status, 2) == FAILURE) return FAILURE; - if (type_check (status, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE) return FAILURE; @@ -4037,7 +4694,7 @@ gfc_check_dtime_etime (gfc_expr *x) if (rank_check (x, 0, 1) == FAILURE) return FAILURE; - if (variable_check (x, 0) == FAILURE) + if (variable_check (x, 0, false) == FAILURE) return FAILURE; if (type_check (x, 0, BT_REAL) == FAILURE) @@ -4059,7 +4716,7 @@ gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) if (rank_check (values, 0, 1) == FAILURE) return FAILURE; - if (variable_check (values, 0) == FAILURE) + if (variable_check (values, 0, false) == FAILURE) return FAILURE; if (type_check (values, 0, BT_REAL) == FAILURE) @@ -4136,7 +4793,7 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind " "not wider than the default kind (%d)", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pos->where, gfc_default_integer_kind); return FAILURE; } @@ -4249,7 +4906,7 @@ gfc_check_itime_idate (gfc_expr *values) if (rank_check (values, 0, 1) == FAILURE) return FAILURE; - if (variable_check (values, 0) == FAILURE) + if (variable_check (values, 0, false) == FAILURE) return FAILURE; if (type_check (values, 0, BT_INTEGER) == FAILURE) @@ -4280,7 +4937,7 @@ gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) if (rank_check (values, 1, 1) == FAILURE) return FAILURE; - if (variable_check (values, 1) == FAILURE) + if (variable_check (values, 1, false) == FAILURE) return FAILURE; if (type_check (values, 1, BT_INTEGER) == FAILURE) @@ -4422,18 +5079,11 @@ gfc_check_signal (gfc_expr *number, gfc_expr *handler) { if (scalar_check (number, 0) == FAILURE) return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -4446,18 +5096,11 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) { if (scalar_check (number, 0) == FAILURE) return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -4466,7 +5109,6 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) if (type_check (status, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (scalar_check (status, 2) == FAILURE) return FAILURE; @@ -4502,7 +5144,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &i->where); return FAILURE; } @@ -4510,7 +5152,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or LOGICAL", gfc_current_intrinsic_arg[1], + "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return FAILURE; } @@ -4518,8 +5160,8 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (i->ts.type != j->ts.type) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return FAILURE; } @@ -4532,3 +5174,27 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) return SUCCESS; } + + +gfc_try +gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + if (kind == NULL) + return SUCCESS; + + if (type_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (kind, 1) == FAILURE) + return FAILURE; + + if (kind->expr_type != EXPR_CONSTANT) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &kind->where); + return FAILURE; + } + + return SUCCESS; +}