From 7fe55cc9b5cb286536e9a39730bc01ca879d0fef Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Sun, 12 Aug 2007 19:57:01 +0000 Subject: [PATCH] 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127380 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 54 +++++++++ gcc/fortran/check.c | 93 ++++++++++++++-- gcc/fortran/intrinsic.c | 67 ++++++----- gcc/fortran/intrinsic.h | 60 +++++----- gcc/fortran/intrinsic.texi | 110 ++++++++++++------ gcc/fortran/iresolve.c | 88 ++++++++++++--- gcc/fortran/simplify.c | 123 ++++++++++++++------- gcc/fortran/trans-decl.c | 11 +- gcc/fortran/trans-intrinsic.c | 90 ++------------- gcc/testsuite/ChangeLog | 6 + .../gfortran.dg/intrinsics_kind_argument_1.f90 | 54 +++++++++ gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 | 2 +- 12 files changed, 520 insertions(+), 238 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intrinsics_kind_argument_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cbd28a5..ecb7569 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,57 @@ +2007-08-12 Francois-Xavier Coudert + + 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 PR fortran/31189 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index ba72aaa..f0de08f 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 71d53ff..59006b2 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index c8548d1..79cf3e5 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 14c746b..f09246c 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index d0a73bf..e318615 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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); } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 88a146b..c3c23cb 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4b0902f..e9b9480 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); + } } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b9dbf46..c8e1646 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4029152..b2ae17c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-08-12 Francois-Xavier Coudert + + 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 PR fortran/32937 diff --git a/gcc/testsuite/gfortran.dg/intrinsics_kind_argument_1.f90 b/gcc/testsuite/gfortran.dg/intrinsics_kind_argument_1.f90 new file mode 100644 index 0000000..b02ff74 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsics_kind_argument_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 index 4b0b8ae..c1bc172 100644 --- a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 +++ b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 @@ -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 -- 2.7.4