+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
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;
}
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;
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 "
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;
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;
}
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;
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;
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;
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_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;
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_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;
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;
}
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);
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);
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);
/* 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);
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);
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);
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);
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);
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);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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. */
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
@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
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
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
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
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
@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}
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
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}
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}
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
Inquiry function
@item @emph{Syntax}:
-@code{RESULT = SIZE(ARRAY[, DIM])}
+@code{RESULT = SIZE(ARRAY[, DIM [, KIND]])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@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
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
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
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)
{
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);
}
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)
{
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)
{
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);
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);
}
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);
}
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;
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)
{
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);
}
{
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;
}
}
+/* 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
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;
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");
gfc_expr *
-gfc_simplify_ichar (gfc_expr *e)
+gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
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");
}
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;
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;
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)
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)
{
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;
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)
/* 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;
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. */
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");
}
&& 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");
}
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++)
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;
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;
{
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)
{
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)
{
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;
}
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;
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;
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);
+ }
}
}
/* 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;
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);
}
}
-/* 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
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:
break;
case GFC_ISYM_INDEX:
- gfc_conv_intrinsic_index (se, expr);
+ gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
break;
case GFC_ISYM_IOR:
+2007-08-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/29600
+ * gfortran.dg/intrinsics_kind_argument_1.f90: New test.
+ * gfortran.dg/pure_dummy_length_1.f90: Adapt to new error wording.
+
2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/32937
--- /dev/null
+! 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
character(*), intent(in) :: string\r
integer(4), intent(in) :: ignore_case\r
integer(4) :: same\r
- if (len (self) < 1) return ! { dg-error "Type of argument" }\r
+ if (len (self) < 1) return ! { dg-error "must be CHARACTER" }\r
same = 1\r
end function\r
\r
projects / platform / upstream / linaro-gcc.git / commitdiff