mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-16 07:23:48 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Francois-Xavier Coudert 2007-08-12 19:57:01 +00:00 committed by François-Xavier Coudert
parent 9687668119
commit 5cda509805
12 changed files with 520 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
gcc/fortran/ChangeLog
View File

@ -1,3 +1,57 @@
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

93
gcc/fortran/check.c
View File

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

67
gcc/fortran/intrinsic.c
View File

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

60
gcc/fortran/intrinsic.h
View File

@ -44,7 +44,7 @@ try gfc_check_chdir (gfc_expr *);
try gfc_check_chmod (gfc_expr *, gfc_expr *);
try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_complex (gfc_expr *, gfc_expr *);
try gfc_check_count (gfc_expr *, gfc_expr *);
try gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_ctime (gfc_expr *);
try gfc_check_dcmplx (gfc_expr *, gfc_expr *);
@ -69,10 +69,10 @@ try gfc_check_and (gfc_expr *, gfc_expr *);
try gfc_check_ibclr (gfc_expr *, gfc_expr *);
try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_ibset (gfc_expr *, gfc_expr *);
try gfc_check_ichar_iachar (gfc_expr *);
try gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
try gfc_check_idnint (gfc_expr *);
try gfc_check_ieor (gfc_expr *, gfc_expr *);
try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_int (gfc_expr *, gfc_expr *);
try gfc_check_intconv (gfc_expr *);
try gfc_check_ior (gfc_expr *, gfc_expr *);
@ -83,7 +83,8 @@ try gfc_check_ishft (gfc_expr *, gfc_expr *);
try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_kill (gfc_expr *, gfc_expr *);
try gfc_check_kind (gfc_expr *);
try gfc_check_lbound (gfc_expr *, gfc_expr *);
try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
try gfc_check_link (gfc_expr *, gfc_expr *);
try gfc_check_loc (gfc_expr *);
try gfc_check_logical (gfc_expr *, gfc_expr *);
@ -111,14 +112,14 @@ try gfc_check_rename (gfc_expr *, gfc_expr *);
try gfc_check_repeat (gfc_expr *, gfc_expr *);
try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_scale (gfc_expr *, gfc_expr *);
try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_second_sub (gfc_expr *);
try gfc_check_secnds (gfc_expr *);
try gfc_check_selected_int_kind (gfc_expr *);
try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *);
try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
try gfc_check_shape (gfc_expr *);
try gfc_check_size (gfc_expr *, gfc_expr *);
try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_sign (gfc_expr *, gfc_expr *);
try gfc_check_signal (gfc_expr *, gfc_expr *);
try gfc_check_sizeof (gfc_expr *);
@ -131,11 +132,11 @@ try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_transpose (gfc_expr *);
try gfc_check_trim (gfc_expr *);
try gfc_check_ttynam (gfc_expr *);
try gfc_check_ubound (gfc_expr *, gfc_expr *);
try gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_umask (gfc_expr *);
try gfc_check_unlink (gfc_expr *);
try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_x (gfc_expr *);
@ -221,14 +222,14 @@ gfc_expr *gfc_simplify_float (gfc_expr *);
gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_fraction (gfc_expr *);
gfc_expr *gfc_simplify_huge (gfc_expr *);
gfc_expr *gfc_simplify_iachar (gfc_expr *);
gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ichar (gfc_expr *);
gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int2 (gfc_expr *);
gfc_expr *gfc_simplify_int8 (gfc_expr *);
@ -239,9 +240,9 @@ gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_kind (gfc_expr *);
gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_len (gfc_expr *);
gfc_expr *gfc_simplify_len_trim (gfc_expr *);
gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_lge (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_lgt (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_lle (gfc_expr *, gfc_expr *);
@ -274,7 +275,7 @@ gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
@ -282,7 +283,7 @@ gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_shape (gfc_expr *);
gfc_expr *gfc_simplify_sin (gfc_expr *);
gfc_expr *gfc_simplify_sinh (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sngl (gfc_expr *);
gfc_expr *gfc_simplify_spacing (gfc_expr *);
gfc_expr *gfc_simplify_sqrt (gfc_expr *);
@ -291,8 +292,8 @@ gfc_expr *gfc_simplify_tanh (gfc_expr *);
gfc_expr *gfc_simplify_tiny (gfc_expr *);
gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_trim (gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
/* Constant conversion simplification. */
@ -330,7 +331,7 @@ void gfc_resolve_complex (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
void gfc_resolve_cos (gfc_expr *, gfc_expr *);
void gfc_resolve_cosh (gfc_expr *, gfc_expr *);
void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_cshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ctime (gfc_expr *, gfc_expr *);
void gfc_resolve_dble (gfc_expr *, gfc_expr *);
@ -362,10 +363,12 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_ierrno (gfc_expr *);
void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ichar (gfc_expr *, gfc_expr *);
void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_iachar (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_int2 (gfc_expr *, gfc_expr *);
@ -378,9 +381,9 @@ void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len (gfc_expr *, gfc_expr *);
void gfc_resolve_len_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len_trim (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_log (gfc_expr *, gfc_expr *);
@ -414,7 +417,8 @@ void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *);
void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_second_sub (gfc_code *);
void gfc_resolve_secnds (gfc_expr *, gfc_expr *);
void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *);
@ -423,6 +427,7 @@ void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sin (gfc_expr *, gfc_expr *);
void gfc_resolve_sinh (gfc_expr *, gfc_expr *);
void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
@ -439,11 +444,12 @@ void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_ttynam (gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_umask (gfc_expr *, gfc_expr *);
void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_xor (gfc_expr *, gfc_expr *, gfc_expr *);

110
gcc/fortran/intrinsic.texi
View File

@ -2644,10 +2644,12 @@ Inverse function: @ref{ACOSH}
@table @asis
@item @emph{Description}:
@code{COUNT(MASK [, DIM])} counts the number of @code{.TRUE.} elements of
@var{MASK} along the dimension of @var{DIM}. If @var{DIM} is omitted it is
taken to be @code{1}. @var{DIM} is a scaler of type @code{INTEGER} in the
range of @math{1 /leq DIM /leq n)} where @math{n} is the rank of @var{MASK}.
@code{COUNT(MASK [, DIM [, KIND]])} counts the number of @code{.TRUE.}
elements of @var{MASK} along the dimension of @var{DIM}. If @var{DIM} is
omitted it is taken to be @code{1}. @var{DIM} is a scaler of type
@code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n}
is the rank of @var{MASK}.
@item @emph{Standard}:
F95 and later
@ -2656,17 +2658,21 @@ F95 and later
Transformational function
@item @emph{Syntax}:
@code{RESULT = COUNT(MASK [, DIM])}
@code{RESULT = COUNT(MASK [, DIM [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{MASK} @tab The type shall be @code{LOGICAL}.
@item @var{DIM} @tab The type shall be @code{INTEGER}.
@item @var{DIM} @tab (Optional) The type shall be @code{INTEGER}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} with rank equal to that of
@var{MASK}.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
The result has a rank equal to that of @var{MASK}.
@item @emph{Example}:
@smallexample
@ -5112,16 +5118,19 @@ F95 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = IACHAR(C)}
@code{RESULT = IACHAR(C [, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
@item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default integer
kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{Example}:
@smallexample
@ -5366,16 +5375,19 @@ F95 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = ICHAR(C)}
@code{RESULT = ICHAR(C [, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
@item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)}
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default integer
kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{Example}:
@smallexample
@ -5552,7 +5564,7 @@ F77 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = INDEX(STRING, SUBSTRING [, BACK])}
@code{RESULT = INDEX(STRING, SUBSTRING [, BACK [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@ -5562,11 +5574,14 @@ Elemental function
@code{INTENT(IN)}
@item @var{BACK} @tab (Optional) Shall be a scalar @code{LOGICAL(*)}, with
@code{INTENT(IN)}
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default integer
kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{See also}:
@ref{SCAN}, @ref{VERIFY}
@ -6111,15 +6126,20 @@ F95 and later
Inquiry function
@item @emph{Syntax}:
@code{RESULT = LBOUND(ARRAY [, DIM])}
@code{RESULT = LBOUND(ARRAY [, DIM [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{ARRAY} @tab Shall be an array, of any type.
@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER(*)}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
If @var{DIM} is absent, the result is an array of the lower bounds of
@var{ARRAY}. If @var{DIM} is present, the result is a scalar
corresponding to the lower bound of the array along that dimension. If
@ -6152,16 +6172,20 @@ F77 and later
Inquiry function
@item @emph{Syntax}:
@code{L = LEN(STRING)}
@code{L = LEN(STRING [, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{STRING} @tab Shall be a scalar or array of type
@code{CHARACTER(*)}, with @code{INTENT(IN)}
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is an @code{INTEGER} of the default kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{See also}:
@ref{LEN_TRIM}, @ref{ADJUSTL}, @ref{ADJUSTR}
@ -6185,16 +6209,20 @@ F95 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = LEN_TRIM(STRING)}
@code{RESULT = LEN_TRIM(STRING [, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER(*)},
with @code{INTENT(IN)}
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is an @code{INTEGER} of the default kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{See also}:
@ref{LEN}, @ref{ADJUSTL}, @ref{ADJUSTR}
@ -8788,18 +8816,21 @@ F95 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = SCAN(STRING, SET[, BACK])}
@code{RESULT = SCAN(STRING, SET[, BACK [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{STRING} @tab Shall be of type @code{CHARACTER(*)}.
@item @var{SET} @tab Shall be of type @code{CHARACTER(*)}.
@item @var{BACK} @tab (Optional) shall be of type @code{LOGICAL}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default
integer kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{Example}:
@smallexample
@ -9342,7 +9373,7 @@ F95 and later
Inquiry function
@item @emph{Syntax}:
@code{RESULT = SIZE(ARRAY[, DIM])}
@code{RESULT = SIZE(ARRAY[, DIM [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@ -9351,11 +9382,14 @@ a pointer it must be associated and allocatable arrays must be allocated.
@item @var{DIM} @tab (Optional) shall be a scalar of type @code{INTEGER}
and its value shall be in the range from 1 to n, where n equals the rank
of @var{ARRAY}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default
integer kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{Example}:
@smallexample
@ -10367,15 +10401,20 @@ F95 and later
Inquiry function
@item @emph{Syntax}:
@code{RESULT = UBOUND(ARRAY [, DIM])}
@code{RESULT = UBOUND(ARRAY [, DIM [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{ARRAY} @tab Shall be an array, of any type.
@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER(*)}.
@item @var{KIND}@tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
If @var{DIM} is absent, the result is an array of the upper bounds of
@var{ARRAY}. If @var{DIM} is present, the result is a scalar
corresponding to the upper bound of the array along that dimension. If
@ -10533,18 +10572,21 @@ F95 and later
Elemental function
@item @emph{Syntax}:
@code{RESULT = VERIFY(STRING, SET[, BACK])}
@code{RESULT = VERIFY(STRING, SET[, BACK [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{STRING} @tab Shall be of type @code{CHARACTER(*)}.
@item @var{SET} @tab Shall be of type @code{CHARACTER(*)}.
@item @var{BACK} @tab (Optional) shall be of type @code{LOGICAL}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of
the result.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the default
integer kind.
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
@item @emph{Example}:
@smallexample

88
gcc/fortran/iresolve.c
View File

@ -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);
}
@ -1872,6 +1906,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)
{
@ -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);
}

123
gcc/fortran/simplify.c
View File

@ -115,14 +115,12 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
gfc_error ("KIND parameter of %s at %L must be an initialization "
"expression", name, &k->where);
return -1;
}
if (gfc_extract_int (k, &kind) != NULL
|| gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
return -1;
}
@ -131,6 +129,20 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
}
/* Helper function to get an integer constant with a kind number given
by an integer constant expression. */
static gfc_expr *
int_expr_with_kind (int i, gfc_expr *kind, const char *name)
{
gfc_expr *res = gfc_int_expr (i);
res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
if (res->ts.kind == -1)
return NULL;
else
return res;
}
/* Converts an mpz_t signed variable into an unsigned one, assuming
two's complement representations and a binary width of bitsize.
The conversion is a no-op unless x is negative; otherwise, it can
@ -1198,7 +1210,7 @@ gfc_simplify_huge (gfc_expr *e)
systems that gfortran currently works on are ASCII. */
gfc_expr *
gfc_simplify_iachar (gfc_expr *e)
gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
@ -1218,7 +1230,9 @@ gfc_simplify_iachar (gfc_expr *e)
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
result = gfc_int_expr (index);
if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
return &gfc_bad_expr;
result->where = e->where;
return range_check (result, "IACHAR");
@ -1380,7 +1394,7 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
gfc_expr *
gfc_simplify_ichar (gfc_expr *e)
gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
@ -1399,7 +1413,9 @@ gfc_simplify_ichar (gfc_expr *e)
if (index < 0 || index > UCHAR_MAX)
gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
result = gfc_int_expr (index);
if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
return &gfc_bad_expr;
result->where = e->where;
return range_check (result, "ICHAR");
}
@ -1422,7 +1438,7 @@ gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
gfc_expr *
gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back, len, lensub;
@ -1436,8 +1452,11 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
else
back = 0;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&x->where);
k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
result = gfc_constant_result (BT_INTEGER, k, &x->where);
len = x->value.character.length;
lensub = y->value.character.length;
@ -1938,9 +1957,11 @@ gfc_simplify_kind (gfc_expr *e)
static gfc_expr *
simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
gfc_array_spec *as)
{
gfc_expr *l, *u, *result;
int k;
/* The last dimension of an assumed-size array is special. */
if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
@ -1958,8 +1979,12 @@ simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&array->where);
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
result = gfc_constant_result (BT_INTEGER, k, &array->where);
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
{
@ -1983,7 +2008,7 @@ simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
static gfc_expr *
simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
@ -2039,6 +2064,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
gfc_expr *e;
gfc_constructor *head, *tail;
int k;
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
if (upper && as->type == AS_ASSUMED_SIZE)
@ -2051,7 +2077,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
bounds[d] = simplify_bound_dim (array, d + 1, upper, as);
bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
@ -2067,7 +2093,11 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
e->where = array->where;
e->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER;
e->ts.kind = gfc_default_integer_kind;
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
e->ts.kind = k;
/* The result is a rank 1 array; its size is the rank of the first
argument to {L,U}BOUND. */
@ -2110,27 +2140,30 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
return &gfc_bad_expr;
}
return simplify_bound_dim (array, d, upper, as);
return simplify_bound_dim (array, kind, d, upper, as);
}
}
gfc_expr *
gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim)
gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
return simplify_bound (array, dim, 0);
return simplify_bound (array, dim, kind, 0);
}
gfc_expr *
gfc_simplify_len (gfc_expr *e)
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
if (e->expr_type == EXPR_CONSTANT)
{
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set_si (result->value.integer, e->value.character.length);
return range_check (result, "LEN");
}
@ -2139,8 +2172,7 @@ gfc_simplify_len (gfc_expr *e)
&& e->ts.cl->length->expr_type == EXPR_CONSTANT
&& e->ts.cl->length->ts.type == BT_INTEGER)
{
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set (result->value.integer, e->ts.cl->length->value.integer);
return range_check (result, "LEN");
}
@ -2150,17 +2182,19 @@ gfc_simplify_len (gfc_expr *e)
gfc_expr *
gfc_simplify_len_trim (gfc_expr *e)
gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int count, len, lentrim, i;
int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
for (count = 0, i = 1; i <= len; i++)
@ -3323,12 +3357,16 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
gfc_expr *
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back;
size_t i;
size_t indx, len, lenc;
int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
return NULL;
@ -3338,8 +3376,7 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
else
back = 0;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&e->where);
result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
lenc = c->value.character.length;
@ -3545,7 +3582,7 @@ gfc_simplify_shape (gfc_expr *source)
{
mpz_set_ui (e->value.integer, n + 1);
f = gfc_simplify_size (source, e);
f = gfc_simplify_size (source, e, NULL);
gfc_free_expr (e);
if (f == NULL)
{
@ -3566,11 +3603,15 @@ gfc_simplify_shape (gfc_expr *source)
gfc_expr *
gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
gfc_expr *result;
int d;
int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
if (dim == NULL)
{
@ -3587,11 +3628,8 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
return NULL;
}
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&array->where);
result = gfc_constant_result (BT_INTEGER, k, &array->where);
mpz_set (result->value.integer, size);
return result;
}
@ -4028,19 +4066,23 @@ gfc_simplify_trim (gfc_expr *e)
gfc_expr *
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
return simplify_bound (array, dim, 1);
return simplify_bound (array, dim, kind, 1);
}
gfc_expr *
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
int back;
size_t index, len, lenset;
size_t i;
int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
return NULL;
@ -4050,8 +4092,7 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
else
back = 0;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&s->where);
result = gfc_constant_result (BT_INTEGER, k, &s->where);
len = s->value.character.length;
lenset = set->value.character.length;

11
gcc/fortran/trans-decl.c
View File

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

90
gcc/fortran/trans-intrinsic.c
View File

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

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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

54
gcc/testsuite/gfortran.dg/intrinsics_kind_argument_1.f90 Normal file
View File

@ -0,0 +1,54 @@
! 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

2
gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90
View File

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