Commit 5cda5098 by Francois-Xavier Coudert Committed by François-Xavier Coudert

re PR fortran/29600 ([F03] MINLOC and MAXLOC take an optional KIND argument)

	PR fortran/29600

	* intrinsic.c (add_functions): Add KIND arguments to COUNT,
	IACHAR, ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND
	and VERIFY.
	* iresolve.c (gfc_resolve_count): Add kind argument.
	(gfc_resolve_iachar): New function.
	(gfc_resolve_ichar): Add kind argument.
	(gfc_resolve_index_func): Likewise.
	(gfc_resolve_lbound): Likewise.
	(gfc_resolve_len): Likewise.
	(gfc_resolve_len_trim): Likewise.
	(gfc_resolve_scan): Likewise.
	(gfc_resolve_size): New function.
	(gfc_resolve_ubound): Add kind argument.
	(gfc_resolve_verify): Likewise.
	* trans-decl.c (gfc_get_extern_function_decl): Allow specific
	intrinsics to have 4 arguments.
	* check.c (gfc_check_count): Add kind argument.
	(gfc_check_ichar_iachar): Likewise.
	(gfc_check_index): Likewise.
	(gfc_check_lbound): Likewise.
	(gfc_check_len_lentrim): New function.
	(gfc_check_scan): Add kind argument.
	(gfc_check_size): Likewise.
	(gfc_check_ubound): Likewise.
	(gfc_check_verify): Likewise.
	* intrinsic.texi: Update documentation for COUNT, IACHAR, ICHAR,
	INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND and VERIFY.
	* simplify.c (get_kind): Whitespace fix.
	(int_expr_with_kind): New function.
	(gfc_simplify_iachar): Add kind argument.
	(gfc_simplify_iachar): Likewise.
	(gfc_simplify_ichar): Likewise.
	(gfc_simplify_index): Likewise.
	(simplify_bound_dim): Likewise.
	(simplify_bound): Likewise.
	(gfc_simplify_lbound): Likewise.
	(gfc_simplify_len): Likewise.
	(gfc_simplify_len_trim): Likewise.
	(gfc_simplify_scan): Likewise.
	(gfc_simplify_shape): Pass NULL as kind argument to gfc_simplify_size.
	(gfc_simplify_size): Add kind argument.
	(gfc_simplify_ubound): Likewise.
	(gfc_simplify_verify): Likewise.
	* intrinsic.h: Update prototypes and add new ones.
	* trans-intrinsic.c (gfc_conv_intrinsic_index): Rename into
	gfc_conv_intrinsic_index_scan_verify.
	(gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify): Remove.
	(gfc_conv_intrinsic_function): Call
	gfc_conv_intrinsic_index_scan_verify to translate the INDEX,
	SCAN and VERIFY intrinsics.

	* gfortran.dg/intrinsics_kind_argument_1.f90: New test.
	* gfortran.dg/pure_dummy_length_1.f90: Adapt to new error wording.

From-SVN: r127380
parent 96876681
2007-08-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/29600
* intrinsic.c (add_functions): Add KIND arguments to COUNT,
IACHAR, ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND
and VERIFY.
* iresolve.c (gfc_resolve_count): Add kind argument.
(gfc_resolve_iachar): New function.
(gfc_resolve_ichar): Add kind argument.
(gfc_resolve_index_func): Likewise.
(gfc_resolve_lbound): Likewise.
(gfc_resolve_len): Likewise.
(gfc_resolve_len_trim): Likewise.
(gfc_resolve_scan): Likewise.
(gfc_resolve_size): New function.
(gfc_resolve_ubound): Add kind argument.
(gfc_resolve_verify): Likewise.
* trans-decl.c (gfc_get_extern_function_decl): Allow specific
intrinsics to have 4 arguments.
* check.c (gfc_check_count): Add kind argument.
(gfc_check_ichar_iachar): Likewise.
(gfc_check_index): Likewise.
(gfc_check_lbound): Likewise.
(gfc_check_len_lentrim): New function.
(gfc_check_scan): Add kind argument.
(gfc_check_size): Likewise.
(gfc_check_ubound): Likewise.
(gfc_check_verify): Likewise.
* intrinsic.texi: Update documentation for COUNT, IACHAR, ICHAR,
INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND and VERIFY.
* simplify.c (get_kind): Whitespace fix.
(int_expr_with_kind): New function.
(gfc_simplify_iachar): Add kind argument.
(gfc_simplify_iachar): Likewise.
(gfc_simplify_ichar): Likewise.
(gfc_simplify_index): Likewise.
(simplify_bound_dim): Likewise.
(simplify_bound): Likewise.
(gfc_simplify_lbound): Likewise.
(gfc_simplify_len): Likewise.
(gfc_simplify_len_trim): Likewise.
(gfc_simplify_scan): Likewise.
(gfc_simplify_shape): Pass NULL as kind argument to gfc_simplify_size.
(gfc_simplify_size): Add kind argument.
(gfc_simplify_ubound): Likewise.
(gfc_simplify_verify): Likewise.
* intrinsic.h: Update prototypes and add new ones.
* trans-intrinsic.c (gfc_conv_intrinsic_index): Rename into
gfc_conv_intrinsic_index_scan_verify.
(gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify): Remove.
(gfc_conv_intrinsic_function): Call
gfc_conv_intrinsic_index_scan_verify to translate the INDEX,
SCAN and VERIFY intrinsics.
2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31189
......
......@@ -786,12 +786,18 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y)
try
gfc_check_count (gfc_expr *mask, gfc_expr *dim)
gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (kind_check (kind, 2, 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;
}
......@@ -1088,13 +1094,21 @@ gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
try
gfc_check_ichar_iachar (gfc_expr *c)
gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
int i;
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
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;
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
{
gfc_expr *start;
......@@ -1181,16 +1195,23 @@ gfc_check_ieor (gfc_expr *i, gfc_expr *j)
try
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
gfc_expr *kind)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (kind_check (kind, 3, 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;
if (string->ts.kind != substring->ts.kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
......@@ -1335,7 +1356,7 @@ gfc_check_kind (gfc_expr *x)
try
gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -1348,6 +1369,31 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
if (dim_rank_check (dim, array, 1) == FAILURE)
return FAILURE;
}
if (kind_check (kind, 2, 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;
}
try
gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
{
if (type_check (s, 0, BT_CHARACTER) == FAILURE)
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;
}
......@@ -2160,7 +2206,7 @@ gfc_check_scale (gfc_expr *x, gfc_expr *i)
try
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2171,6 +2217,13 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (kind_check (kind, 3, 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;
if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
......@@ -2276,7 +2329,7 @@ gfc_check_sign (gfc_expr *a, gfc_expr *b)
try
gfc_check_size (gfc_expr *array, gfc_expr *dim)
gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -2293,6 +2346,14 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim)
return FAILURE;
}
if (kind_check (kind, 2, 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;
}
......@@ -2603,7 +2664,7 @@ gfc_check_transpose (gfc_expr *matrix)
try
gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
......@@ -2617,6 +2678,13 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
return FAILURE;
}
if (kind_check (kind, 2, 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;
}
......@@ -2641,7 +2709,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
try
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
......@@ -2652,6 +2720,13 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (kind_check (kind, 3, 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;
}
......
......@@ -1256,9 +1256,11 @@ add_functions (void)
make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
add_sym_2 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_count, NULL, gfc_resolve_count,
msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
......@@ -1484,9 +1486,10 @@ add_functions (void)
make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
add_sym_1 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_ichar_iachar, gfc_simplify_iachar, NULL,
c, BT_CHARACTER, dc, REQUIRED);
add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar,
c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
......@@ -1526,9 +1529,10 @@ add_functions (void)
make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
add_sym_1 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F77,
gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
c, BT_CHARACTER, dc, REQUIRED);
c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
......@@ -1551,10 +1555,11 @@ add_functions (void)
/* The resolution function for INDEX is called gfc_resolve_index_func
because the name gfc_resolve_index is already used in resolve.c. */
add_sym_3 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
BT_INTEGER, di, GFC_STD_F77,
gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
bck, BT_LOGICAL, dl, OPTIONAL);
bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
......@@ -1660,21 +1665,25 @@ add_functions (void)
make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
add_sym_2 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
add_sym_1 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
NULL, gfc_simplify_len, gfc_resolve_len,
stg, BT_CHARACTER, dc, REQUIRED);
add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
BT_INTEGER, di, GFC_STD_F77,
gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
add_sym_1 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
stg, BT_CHARACTER, dc, REQUIRED);
add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim,
stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
make_alias ("lnblnk", GFC_STD_GNU);
......@@ -2040,10 +2049,11 @@ add_functions (void)
make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
add_sym_3 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
bck, BT_LOGICAL, dl, OPTIONAL);
bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
......@@ -2136,9 +2146,11 @@ add_functions (void)
make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
add_sym_2 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_size, gfc_simplify_size, NULL,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_size, gfc_simplify_size, gfc_resolve_size,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
......@@ -2267,9 +2279,11 @@ add_functions (void)
make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
add_sym_2 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
......@@ -2294,10 +2308,11 @@ add_functions (void)
make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
add_sym_3 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
bck, BT_LOGICAL, dl, OPTIONAL);
bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
......
......@@ -520,10 +520,13 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
void
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
if (dim != NULL)
{
......@@ -856,10 +859,25 @@ gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
void
gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}
void
gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}
......@@ -920,12 +938,16 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
void
gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
gfc_expr *kind)
{
gfc_typespec ts;
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
if (back && back->ts.kind != gfc_default_integer_kind)
{
......@@ -1057,12 +1079,15 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
void
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
static char lbound[] = "__lbound";
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
{
......@@ -1076,10 +1101,13 @@ gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
void
gfc_resolve_len (gfc_expr *f, gfc_expr *string)
gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name
= gfc_get_string ("__len_%d_i%d", string->ts.kind,
gfc_default_integer_kind);
......@@ -1087,10 +1115,13 @@ gfc_resolve_len (gfc_expr *f, gfc_expr *string)
void
gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
}
......@@ -1776,10 +1807,13 @@ gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
void
gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
gfc_expr *back ATTRIBUTE_UNUSED)
gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
}
......@@ -1873,6 +1907,18 @@ gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
void
gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
}
void
gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
int k;
......@@ -2265,12 +2311,15 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
void
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
static char ubound[] = "__ubound";
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
{
......@@ -2343,10 +2392,13 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
void
gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
gfc_expr *back ATTRIBUTE_UNUSED)
gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (kind)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
}
......
......@@ -1109,9 +1109,14 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
isym->resolve.f2 (&e, &argexpr, NULL);
else
{
/* All specific intrinsics take less than 4 arguments. */
gcc_assert (isym->formal->next->next->next == NULL);
isym->resolve.f3 (&e, &argexpr, NULL, NULL);
if (isym->formal->next->next->next == NULL)
isym->resolve.f3 (&e, &argexpr, NULL, NULL);
else
{
/* All specific intrinsics take less than 5 arguments. */
gcc_assert (isym->formal->next->next->next->next == NULL);
isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
}
}
}
......
......@@ -2759,7 +2759,8 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
/* Returns the starting position of a substring within a string. */
static void
gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
tree function)
{
tree logical4_type_node = gfc_get_logical_type (4);
tree type;
......@@ -2770,20 +2771,18 @@ gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
num_args = gfc_intrinsic_argument_list_length (expr);
args = alloca (sizeof (tree) * 5);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
gfc_conv_intrinsic_function_args (se, expr, args,
num_args >= 5 ? 5 : num_args);
type = gfc_typenode_for_spec (&expr->ts);
if (num_args == 4)
args[4] = build_int_cst (logical4_type_node, 0);
else
{
gcc_assert (num_args == 5);
args[4] = convert (logical4_type_node, args[4]);
}
args[4] = convert (logical4_type_node, args[4]);
fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
fndecl, 5, args);
fndecl = build_addr (function, current_function_decl);
se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
5, args);
se->expr = convert (type, se->expr);
}
......@@ -3471,73 +3470,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
}
/* Scan a string for any one of the characters in a set of characters. */
static void
gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
{
tree logical4_type_node = gfc_get_logical_type (4);
tree type;
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr);
args = alloca (sizeof (tree) * 5);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
if (num_args == 4)
args[4] = build_int_cst (logical4_type_node, 0);
else
{
gcc_assert (num_args == 5);
args[4] = convert (logical4_type_node, args[4]);
}
fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
fndecl, 5, args);
se->expr = convert (type, se->expr);
}
/* Verify that a set of characters contains all the characters in a string
by identifying the position of the first character in a string of
characters that does not appear in a given set of characters. */
static void
gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
{
tree logical4_type_node = gfc_get_logical_type (4);
tree type;
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr);
args = alloca (sizeof (tree) * 5);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
if (num_args == 4)
args[4] = build_int_cst (logical4_type_node, 0);
else
{
gcc_assert (num_args == 5);
args[4] = convert (logical4_type_node, args[4]);
}
fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
fndecl, 5, args);
se->expr = convert (type, se->expr);
}
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
static void
......@@ -3862,11 +3794,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_SCAN:
gfc_conv_intrinsic_scan (se, expr);
gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
break;
case GFC_ISYM_VERIFY:
gfc_conv_intrinsic_verify (se, expr);
gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
break;
case GFC_ISYM_ALLOCATED:
......@@ -4029,7 +3961,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_INDEX:
gfc_conv_intrinsic_index (se, expr);
gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
break;
case GFC_ISYM_IOR:
......
2007-08-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/29600
* gfortran.dg/intrinsics_kind_argument_1.f90: New test.
* gfortran.dg/pure_dummy_length_1.f90: Adapt to new error wording.
2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/32937
! Test various intrinsics who take a kind argument since Fortran 2003
!
! { dg-do compile }
!
program test
integer, parameter :: k = kind(0)
logical :: l_array(4,5)
character(len=1) :: s
character(len=20) :: t
l_array = .true.
s = "u"
t = "bartutugee"
call check (count(l_array, kind=k), 20)
if (any (count(l_array, 2, kind=k) /= 5)) call abort
if (any (count(l_array, kind=k, dim=2) /= 5)) call abort
call check (iachar (s, k), 117)
call check (iachar (s, kind=k), 117)
call check (ichar (s, k), 117)
call check (ichar (s, kind=k), 117)
call check (index (t, s, .true., k), 7)
call check (index (t, s, kind=k, back=.false.), 5)
if (any (lbound (l_array, kind=k) /= 1)) call abort
call check (lbound (l_array, 1), 1)
call check (lbound (l_array, 1, kind=k), 1)
if (any (ubound (l_array, kind=k) /= (/4, 5/))) call abort
call check (ubound (l_array, 1), 4)
call check (ubound (l_array, 1, kind=k), 4)
call check (len(t, k), 20)
call check (len_trim(t, k), 10)
call check (scan (t, s, .true., k), 7)
call check (scan (t, s, kind=k, back=.false.), 5)
call check (size (l_array, 1, kind=k), 4)
call check (size (l_array, kind=k), 20)
call check (verify (t, s, .true., k), 20)
call check (verify (t, s, kind=k, back=.false.), 1)
contains
subroutine check(x,y)
integer, intent(in) :: x, y
if (x /= y) call abort
end subroutine check
end program test
......@@ -10,7 +10,7 @@
character(*), intent(in) :: string
integer(4), intent(in) :: ignore_case
integer(4) :: same
if (len (self) < 1) return ! { dg-error "Type of argument" }
if (len (self) < 1) return ! { dg-error "must be CHARACTER" }
same = 1
end function
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment