From b266f68c6db0161616b4e7f3735e888e1486cd8d Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 11 Aug 2010 10:49:56 +0000 Subject: [PATCH] 2010-08-11 Janus Weil PR fortran/44595 * intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to 'gfc_intrinsic_arg'. (check_arglist,check_specific): Add reference to 'name' field. (init_arglist): Remove reference to 'name' field. * intrinsic.h (gfc_current_intrinsic_arg): Modify prototype. * check.c (variable_check): Reverse order of checks. Respect intent of formal arg. (int_or_proc_check): New function. (coarray_check): New function. (allocatable_check): New function. (gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'. (gfc_check_complex): Use 'int_or_real_check'. (gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image, gfc_check_ucobound): Use 'coarray_check'. (gfc_check_pack): Use 'real_or_complex_check'. (gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use 'int_or_proc_check'. (scalar_check,type_check,numeric_check,int_or_real_check, real_or_complex_check,kind_check,double_check,logical_array_check, array_check,same_type_check,rank_check,nonoptional_check, kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx, gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod, gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind, gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null, gfc_check_present,gfc_check_reshape,gfc_check_same_type_as, gfc_check_spread,gfc_check_unpack,gfc_check_random_seed, gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference to 'name' field. 2010-08-11 Janus Weil Steve Kargl PR fortran/44595 * gfortran.dg/move_alloc_3.f90: New. * gfortran.dg/random_seed_2.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163096 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 32 ++ gcc/fortran/check.c | 440 ++++++++++++++-------------- gcc/fortran/intrinsic.c | 10 +- gcc/fortran/intrinsic.h | 2 +- gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/move_alloc_3.f90 | 12 + gcc/testsuite/gfortran.dg/random_seed_2.f90 | 11 + 7 files changed, 285 insertions(+), 229 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/random_seed_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 63884eb..e34b6ac 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,35 @@ +2010-08-11 Janus Weil + + PR fortran/44595 + * intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to + 'gfc_intrinsic_arg'. + (check_arglist,check_specific): Add reference to 'name' field. + (init_arglist): Remove reference to 'name' field. + * intrinsic.h (gfc_current_intrinsic_arg): Modify prototype. + * check.c (variable_check): Reverse order of checks. Respect intent of + formal arg. + (int_or_proc_check): New function. + (coarray_check): New function. + (allocatable_check): New function. + (gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'. + (gfc_check_complex): Use 'int_or_real_check'. + (gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image, + gfc_check_ucobound): Use 'coarray_check'. + (gfc_check_pack): Use 'real_or_complex_check'. + (gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use + 'int_or_proc_check'. + (scalar_check,type_check,numeric_check,int_or_real_check, + real_or_complex_check,kind_check,double_check,logical_array_check, + array_check,same_type_check,rank_check,nonoptional_check, + kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx, + gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod, + gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind, + gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null, + gfc_check_present,gfc_check_reshape,gfc_check_same_type_as, + gfc_check_spread,gfc_check_unpack,gfc_check_random_seed, + gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference + to 'name' field. + 2010-08-10 Daniel Kraft * gfortran.texi (Interoperability with C): Fix ordering in menu diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 7578775..ad040f1 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -43,7 +43,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 +59,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 +87,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 +102,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 +119,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 +165,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 +193,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; } @@ -209,6 +228,21 @@ is_coarray (gfc_expr *e) } +static gfc_try +coarray_check (gfc_expr *e, int n) +{ + if (!is_coarray (e)) + { + 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 SUCCESS; +} + + /* Make sure the expression is a logical array. */ static gfc_try @@ -217,8 +251,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; } @@ -235,7 +269,8 @@ array_check (gfc_expr *e, int n) 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; } @@ -324,8 +359,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 +376,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 +391,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 +401,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 +430,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; @@ -386,23 +442,25 @@ kind_value_check (gfc_expr *e, int n, int k) static gfc_try variable_check (gfc_expr *e, int n) { - 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) + && 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_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } + 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; + 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; } @@ -666,20 +724,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) 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; } @@ -696,8 +745,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; } @@ -743,7 +792,7 @@ 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; } @@ -761,15 +810,16 @@ 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; } @@ -962,16 +1012,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; } @@ -987,23 +1039,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; @@ -1071,7 +1113,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])); @@ -1085,7 +1127,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; } @@ -1129,16 +1171,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; } } @@ -1186,7 +1230,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; } @@ -1200,8 +1244,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; } @@ -1219,7 +1263,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; } @@ -1227,7 +1271,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; } @@ -1277,7 +1321,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])); @@ -1291,7 +1335,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; } @@ -1311,16 +1355,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; } } @@ -1397,8 +1442,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; @@ -1619,9 +1664,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; } @@ -1744,7 +1789,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; } @@ -1785,12 +1830,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) { @@ -2076,7 +2117,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; } @@ -2084,7 +2125,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; } @@ -2108,8 +2149,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; @@ -2127,15 +2168,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; } @@ -2191,8 +2232,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; @@ -2245,8 +2286,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; @@ -2295,31 +2336,15 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) gfc_try gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) { - symbol_attribute attr; - if (variable_check (from, 0) == 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 (variable_check (to, 0) == FAILURE) + if (allocatable_check (from, 0) == FAILURE) return FAILURE; - attr = gfc_variable_attr (to, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &to->where); - return FAILURE; - } + if (variable_check (to, 1) == FAILURE) + return FAILURE; + if (allocatable_check (to, 1) == FAILURE) + return FAILURE; if (same_type_check (to, 1, from, 0) == FAILURE) return FAILURE; @@ -2327,8 +2352,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; } @@ -2336,8 +2361,9 @@ 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; } @@ -2385,7 +2411,7 @@ gfc_check_null (gfc_expr *mold) if (!attr.pointer && !attr.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return FAILURE; } @@ -2405,8 +2431,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; @@ -2459,8 +2485,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; } @@ -2479,13 +2506,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 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; } @@ -2503,7 +2525,7 @@ gfc_check_present (gfc_expr *a) 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; } @@ -2511,8 +2533,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; } @@ -2527,7 +2550,7 @@ gfc_check_present (gfc_expr *a) && a->ref->u.ar.type == AR_FULL)) { 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; } @@ -2662,7 +2685,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; } @@ -2686,7 +2709,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; } @@ -2726,7 +2750,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; @@ -2744,7 +2768,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; } @@ -2753,7 +2777,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; } @@ -2805,32 +2830,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; } @@ -3051,8 +3080,9 @@ gfc_check_c_sizeof (gfc_expr *arg) if (verify_c_interop (&arg->ts) != SUCCESS) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an " - "interoperable data entity", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &arg->where); + "interoperable data entity", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); return FAILURE; } return SUCCESS; @@ -3092,7 +3122,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; @@ -3111,7 +3141,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; } @@ -3366,17 +3396,13 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) 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; } @@ -3403,12 +3429,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) { @@ -3492,12 +3514,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) { @@ -3557,8 +3575,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; } @@ -3570,8 +3588,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; } @@ -3583,8 +3601,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); } } @@ -3842,8 +3860,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) @@ -3874,8 +3892,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. */ @@ -3986,18 +4004,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; @@ -4006,10 +4017,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; @@ -4177,7 +4186,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; } @@ -4463,18 +4472,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; @@ -4487,18 +4489,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; @@ -4507,7 +4502,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; @@ -4543,7 +4537,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; } @@ -4551,7 +4545,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; } @@ -4559,8 +4553,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; } @@ -4590,7 +4584,7 @@ gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind) if (kind->expr_type != EXPR_CONSTANT) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &kind->where); return FAILURE; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 121afc0..c9e3833 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -36,7 +36,7 @@ bool gfc_init_expr_flag = false; checked. */ const char *gfc_current_intrinsic; -const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; @@ -3390,7 +3390,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, { if (error_flag) gfc_error ("Type of argument '%s' in call to '%s' at %L should " - "be %s, not %s", gfc_current_intrinsic_arg[i], + "be %s, not %s", gfc_current_intrinsic_arg[i]->name, gfc_current_intrinsic, &actual->expr->where, gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts)); @@ -3609,7 +3609,7 @@ init_arglist (gfc_intrinsic_sym *isym) { if (i >= MAX_INTRINSIC_ARGS) gfc_internal_error ("init_arglist(): too many arguments"); - gfc_current_intrinsic_arg[i++] = formal->name; + gfc_current_intrinsic_arg[i++] = formal; } } @@ -3678,8 +3678,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) if (gfc_check_conformance (first_expr, arg->expr, "arguments '%s' and '%s' for " "intrinsic '%s'", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[n], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; } diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index f5da7a0..23272a8 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -573,5 +573,5 @@ void gfc_resolve_unlink_sub (gfc_code *); #define MAX_INTRINSIC_ARGS 5 extern const char *gfc_current_intrinsic; -extern const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; extern locus *gfc_current_intrinsic_where; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e8f3744..51fb4a7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-08-11 Janus Weil + Steve Kargl + + PR fortran/44595 + * gfortran.dg/move_alloc_3.f90: New. + * gfortran.dg/random_seed_2.f90: New. + 2010-08-10 John David Anglin * lib/target-supports.exp (check_effective_target_sync_int_long): diff --git a/gcc/testsuite/gfortran.dg/move_alloc_3.f90 b/gcc/testsuite/gfortran.dg/move_alloc_3.f90 new file mode 100644 index 0000000..3855eed --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 44595: INTENT of arguments to intrinsic procedures not checked +! +! Contributed by Janus Weil + +subroutine test(f) + implicit none + integer, allocatable, intent(in) :: f + integer, allocatable :: t + call move_alloc(f,t) ! { dg-error "cannot be INTENT.IN." } +end subroutine diff --git a/gcc/testsuite/gfortran.dg/random_seed_2.f90 b/gcc/testsuite/gfortran.dg/random_seed_2.f90 new file mode 100644 index 0000000..52728f8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/random_seed_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 44595: INTENT of arguments to intrinsic procedures not checked +! +! Contributed by Steve Kargl + +subroutine reset_seed(iseed) + implicit none + integer, intent(in) :: iseed + call random_seed(iseed) ! { dg-error "cannot be INTENT.IN." } +end subroutine reset_seed -- 2.7.4