OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/44595 (INTENT of arguments to intrinsic procedures not checked)

Browse Source 
2010-08-11  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>
	    Steve Kargl <kargl@gcc.gnu.org>

	PR fortran/44595
	* gfortran.dg/move_alloc_3.f90: New.
	* gfortran.dg/random_seed_2.f90: New.

Co-Authored-By: Steve Kargl <kargl@gcc.gnu.org>

From-SVN: r163096
This commit is contained in:
Janus Weil 2010-08-11 12:49:56 +02:00
parent 481e1176d7
commit c4aa95f885
7 changed files with 286 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/fortran/ChangeLog
View File

@ -1,3 +1,35 @@
2010-08-11 Janus Weil <janus@gcc.gnu.org>
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 <d@domob.eu>
* gfortran.texi (Interoperability with C): Fix ordering in menu

442
gcc/fortran/check.c
View File

@ -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.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]->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;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
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_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;
}

10
gcc/fortran/intrinsic.c
View File

@ -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;
}

2
gcc/fortran/intrinsic.h
View File

@ -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;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2010-08-11 Janus Weil <janus@gcc.gnu.org>
Steve Kargl <kargl@gcc.gnu.org>
PR fortran/44595
* gfortran.dg/move_alloc_3.f90: New.
* gfortran.dg/random_seed_2.f90: New.
2010-08-10 John David Anglin <dave.anglin@nrc-cnrc.gc.ca>
* lib/target-supports.exp (check_effective_target_sync_int_long):

12
gcc/testsuite/gfortran.dg/move_alloc_3.f90 Normal file
View File

@ -0,0 +1,12 @@
! { dg-do compile }
!
! PR 44595: INTENT of arguments to intrinsic procedures not checked
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
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

11
gcc/testsuite/gfortran.dg/random_seed_2.f90 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
!
! PR 44595: INTENT of arguments to intrinsic procedures not checked
!
! Contributed by Steve Kargl <kargl@gcc.gnu.org>
subroutine reset_seed(iseed)
implicit none
integer, intent(in) :: iseed
call random_seed(iseed) ! { dg-error "cannot be INTENT.IN." }
end subroutine reset_seed