From f622221ab42c4ca550059add89ffda00ed2b3c03 Mon Sep 17 00:00:00 2001 From: Janne Blomqvist Date: Fri, 5 Jan 2018 21:01:12 +0200 Subject: [PATCH] PR 78534 Change character length from int to size_t In order to handle large character lengths on (L)LP64 targets, switch the GFortran character length from an int to a size_t. This is an ABI change, as procedures with character arguments take hidden arguments with the character length. I also changed the _size member in vtables from int to size_t, as there were some cases where character lengths and sizes were apparently mixed up and caused regressions otherwise. Although I haven't tested, this might enable very large derived types as well. Also, as there are some places in the frontend were negative character lengths are used as special flag values, in the frontend the character length is handled as a signed variable of the same size as a size_t, although in the runtime library it really is size_t. I haven't changed the character length variables for the co-array intrinsics, as this is something that may need to be synchronized with OpenCoarrays. This is v5 of the patch. v4 was applied but caused breakage on big endian targets. These have been fixed and tested, thanks to access to the GCC compile farm. Overview of v4 of the patch: v3 was applied but had to reverted due to breaking bootstrap. The fix is in resolve.c:resolve_charlen, where it's necessary to check that an expression is constant before using mpz_sgn. Overview of v3 of the patch: All the issues pointed out by FX's review of v2 have been fixed. In particular, there are now new functions gfc_mpz_get_hwi and gfc_mpz_set_hwi, similar to the GMP functions mpz_get_si and mpz_set_si, except that they get/set a HOST_WIDE_INT instead of a long value. Similarly, gfc_get_int_expr now takes a HOST_WIDE_INT instead of a long, gfc_extract_long is replaced by gfc_extract_hwi. Also, the preliminary work to handle gfc_charlen_type_node being unsigned has been removed. Regtested on x86_64-pc-linux-gnu, i686-pc-linux-gnu and powerpc64-unknown-linux-gnu. Also regtested all three targets by modifying gfortran-dg.exp to also test with "-g -flto", no new failures observed. frontend: 2018-01-05 Janne Blomqvist PR fortran/78534 PR fortran/66310 * array.c (got_charlen): Use gfc_charlen_int_kind. * class.c (gfc_find_derived_vtab): Use gfc_size_kind instead of hardcoded kind. (find_intrinsic_vtab): Likewise. * decl.c (match_char_length): Use gfc_charlen_int_kind. (add_init_expr_to_sym): Use gfc_charlen_t and gfc_charlen_int_kind. (gfc_match_implicit): Use gfc_charlen_int_kind. * dump-parse-tree.c (show_char_const): Use gfc_charlen_t and size_t. (show_expr): Use HOST_WIDE_INT_PRINT_DEC. * expr.c (gfc_get_character_expr): Length parameter of type gfc_charlen_t. (gfc_get_int_expr): Value argument of type HOST_WIDE_INT. (gfc_extract_hwi): New function. (simplify_const_ref): Make string_len of type gfc_charlen_t. (gfc_simplify_expr): Use HOST_WIDE_INT for substring refs. * frontend-passes.c (optimize_trim): Use gfc_charlen_int_kind. * gfortran.h (gfc_mpz_get_hwi): New prototype. (gfc_mpz_set_hwi): Likewise. (gfc_charlen_t): New typedef. (gfc_expr): Use gfc_charlen_t for character lengths. (gfc_size_kind): New extern variable. (gfc_extract_hwi): New prototype. (gfc_get_character_expr): Use gfc_charlen_t for character length. (gfc_get_int_expr): Use HOST_WIDE_INT type for value argument. * gfortran.texi: Update description of hidden string length argument. * iresolve.c (check_charlen_present): Use gfc_charlen_int_kind. (gfc_resolve_char_achar): Likewise. (gfc_resolve_repeat): Pass string length directly without temporary, use gfc_charlen_int_kind. (gfc_resolve_transfer): Use gfc_charlen_int_kind. * match.c (select_intrinsic_set_tmp): Use HOST_WIDE_INT for charlen. * misc.c (gfc_mpz_get_hwi): New function. (gfc_mpz_set_hwi): New function. * module.c (atom_int): Change type from int to HOST_WIDE_INT. (parse_integer): Don't complain about large integers. (write_atom): Use HOST_WIDE_INT for integers. (mio_integer): Handle integer type mismatch. (mio_hwi): New function. (mio_intrinsic_op): Use HOST_WIDE_INT. (mio_array_ref): Likewise. (mio_expr): Likewise. * primary.c (match_substring): Use gfc_charlen_int_kind. * resolve.c (resolve_substring_charlen): Use gfc_charlen_int_kind. (resolve_character_operator): Likewise. (resolve_assoc_var): Likewise. (resolve_select_type): Use HOST_WIDE_INT for charlen, use snprintf. (resolve_charlen): Use mpz_sgn to determine sign. * simplify.c (gfc_simplify_repeat): Use HOST_WIDE_INT/gfc_charlen_t instead of long. * symbol.c (generate_isocbinding_symbol): Use gfc_charlen_int_kind. * target-memory.c (size_character): Length argument of type gfc_charlen_t. (gfc_encode_character): Likewise. (gfc_interpret_character): Use gfc_charlen_t. * target-memory.h (gfc_encode_character): Modify prototype. * trans-array.c (gfc_trans_array_ctor_element): Use existing type. (get_array_ctor_var_strlen): Use gfc_conv_mpz_to_tree_type. (trans_array_constructor): Use existing type. (get_array_charlen): Likewise. * trans-const.c (gfc_conv_mpz_to_tree_type): New function. * trans-const.h (gfc_conv_mpz_to_tree_type): New prototype. * trans-decl.c (gfc_trans_deferred_vars): Use existing type. (add_argument_checking): Likewise. * trans-expr.c (gfc_class_len_or_zero_get): Build const of type gfc_charlen_type_node. (gfc_conv_intrinsic_to_class): Use gfc_charlen_int_kind instead of 4, fold_convert to correct type. (gfc_conv_class_to_class): Build const of type size_type_node for size. (gfc_copy_class_to_class): Likewise. (gfc_conv_string_length): Use same type in expression. (gfc_conv_substring): Likewise, use HOST_WIDE_INT for charlen. (gfc_conv_string_tmp): Make sure len is of the right type. (gfc_conv_concat_op): Use same type in expression. (gfc_conv_procedure_call): Likewise. (fill_with_spaces): Comment out memset() block due to spurious -Wstringop-overflow warnings. (gfc_trans_string_copy): Use gfc_charlen_type_node. (alloc_scalar_allocatable_for_subcomponent_assignment): fold_convert to right type. (gfc_trans_subcomponent_assign): Likewise. (trans_class_vptr_len_assignment): Build const of correct type. (gfc_trans_pointer_assignment): Likewise. (alloc_scalar_allocatable_for_assignment): fold_convert to right type in expr. (trans_class_assignment): Build const of correct type. * trans-intrinsic.c (gfc_conv_associated): Likewise. (gfc_conv_intrinsic_repeat): Do calculation in sizetype. * trans-io.c (gfc_build_io_library_fndecls): Use gfc_charlen_type_node for character lengths. (set_string): Convert to right type in assignment. * trans-stmt.c (gfc_trans_label_assign): Build const of gfc_charlen_type_node. (trans_associate_var): Likewise. (gfc_trans_character_select): Likewise. (gfc_trans_allocate): Likewise, don't typecast strlen result. (gfc_trans_deallocate): Don't typecast strlen result. * trans-types.c (gfc_size_kind): New variable. (gfc_init_types): Determine gfc_charlen_int_kind and gfc_size_kind from size_type_node. * trans-types.h: Fix comment. testsuite: 2018-01-05 Janne Blomqvist PR fortran/78534 PR fortran/66310 * gfortran.dg/char_cast_1.f90: Update scan pattern. * gfortran.dg/dependency_49.f90: Likewise. * gfortran.dg/repeat_4.f90: Use integers of kind C_SIZE_T. * gfortran.dg/repeat_7.f90: New test for PR 66310. * gfortran.dg/scan_2.f90: Handle potential cast in assignment. * gfortran.dg/string_1.f90: Limit to ilp32 targets. * gfortran.dg/string_1_lp64.f90: New test. * gfortran.dg/string_3.f90: Limit to ilp32 targets. * gfortran.dg/string_3_lp64.f90: New test. libgfortran: 2019-01-05 Janne Blomqvist PR fortran/78534 * intrinsics/args.c (getarg_i4): Use gfc_charlen_type. (get_command_argument_i4): Likewise. (get_command_i4): Likewise. * intrinsics/chmod.c (chmod_internal): Likewise. * intrinsics/env.c (get_environment_variable_i4): Likewise. * intrinsics/extends_type_of.c (struct vtype): Use size_t for size member. * intrinsics/gerror.c (gerror): Use gfc_charlen_type. * intrinsics/getlog.c (getlog): Likewise. * intrinsics/hostnm.c (hostnm_0): Likewise. * intrinsics/string_intrinsics_inc.c (string_len_trim): Rework to work if gfc_charlen_type is unsigned. (string_scan): Likewise. * io/transfer.c (transfer_character): Modify prototype. (transfer_character_write): Likewise. (transfer_character_wide): Likewise. (transfer_character_wide_write): Likewise. (transfer_array): Typecast to avoid signed-unsigned comparison. * io/unit.c (is_trim_ok): Use gfc_charlen_type. * io/write.c (namelist_write): Likewise. * libgfortran.h (gfc_charlen_type): Change typedef to size_t. From-SVN: r256284 --- gcc/fortran/ChangeLog | 106 ++++++++++++++++++ gcc/fortran/array.c | 2 +- gcc/fortran/class.c | 12 +- gcc/fortran/decl.c | 12 +- gcc/fortran/dump-parse-tree.c | 9 +- gcc/fortran/expr.c | 76 +++++++++++-- gcc/fortran/frontend-passes.c | 4 +- gcc/fortran/gfortran.h | 23 +++- gcc/fortran/gfortran.texi | 42 ++++++- gcc/fortran/iresolve.c | 15 ++- gcc/fortran/match.c | 8 +- gcc/fortran/misc.c | 21 ++++ gcc/fortran/module.c | 60 ++++++---- gcc/fortran/primary.c | 2 +- gcc/fortran/resolve.c | 28 ++--- gcc/fortran/simplify.c | 23 ++-- gcc/fortran/symbol.c | 2 +- gcc/fortran/target-memory.c | 19 ++-- gcc/fortran/target-memory.h | 2 +- gcc/fortran/trans-array.c | 17 +-- gcc/fortran/trans-const.c | 12 ++ gcc/fortran/trans-const.h | 1 + gcc/fortran/trans-decl.c | 10 +- gcc/fortran/trans-expr.c | 97 +++++++++------- gcc/fortran/trans-intrinsic.c | 46 ++++---- gcc/fortran/trans-io.c | 7 +- gcc/fortran/trans-stmt.c | 23 ++-- gcc/fortran/trans-types.c | 12 +- gcc/fortran/trans-types.h | 4 +- gcc/testsuite/ChangeLog | 14 +++ gcc/testsuite/gfortran.dg/char_cast_1.f90 | 6 +- gcc/testsuite/gfortran.dg/dependency_49.f90 | 2 +- gcc/testsuite/gfortran.dg/repeat_4.f90 | 23 ++-- gcc/testsuite/gfortran.dg/repeat_7.f90 | 8 ++ gcc/testsuite/gfortran.dg/scan_2.f90 | 4 +- gcc/testsuite/gfortran.dg/string_1.f90 | 1 + gcc/testsuite/gfortran.dg/string_1_lp64.f90 | 15 +++ gcc/testsuite/gfortran.dg/string_3.f90 | 1 + gcc/testsuite/gfortran.dg/string_3_lp64.f90 | 20 ++++ libgfortran/intrinsics/args.c | 10 +- libgfortran/intrinsics/chmod.c | 3 +- libgfortran/intrinsics/env.c | 3 +- libgfortran/intrinsics/extends_type_of.c | 2 +- libgfortran/intrinsics/gerror.c | 2 +- libgfortran/intrinsics/getlog.c | 3 +- libgfortran/intrinsics/hostnm.c | 5 +- .../intrinsics/string_intrinsics_inc.c | 29 ++--- libgfortran/io/transfer.c | 18 +-- libgfortran/io/unit.c | 3 +- libgfortran/io/write.c | 2 +- libgfortran/libgfortran.h | 2 +- 51 files changed, 609 insertions(+), 262 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/repeat_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/string_1_lp64.f90 create mode 100644 gcc/testsuite/gfortran.dg/string_3_lp64.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7eb453dd2cc..b001a8a1845 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,109 @@ +2018-01-05 Janne Blomqvist + + PR fortran/78534 + PR fortran/66310 + * array.c (got_charlen): Use gfc_charlen_int_kind. + * class.c (gfc_find_derived_vtab): Use gfc_size_kind instead of + hardcoded kind. + (find_intrinsic_vtab): Likewise. + * decl.c (match_char_length): Use gfc_charlen_int_kind. + (add_init_expr_to_sym): Use gfc_charlen_t and gfc_charlen_int_kind. + (gfc_match_implicit): Use gfc_charlen_int_kind. + * dump-parse-tree.c (show_char_const): Use gfc_charlen_t and size_t. + (show_expr): Use HOST_WIDE_INT_PRINT_DEC. + * expr.c (gfc_get_character_expr): Length parameter of type + gfc_charlen_t. + (gfc_get_int_expr): Value argument of type HOST_WIDE_INT. + (gfc_extract_hwi): New function. + (simplify_const_ref): Make string_len of type gfc_charlen_t. + (gfc_simplify_expr): Use HOST_WIDE_INT for substring refs. + * frontend-passes.c (optimize_trim): Use gfc_charlen_int_kind. + * gfortran.h (gfc_mpz_get_hwi): New prototype. + (gfc_mpz_set_hwi): Likewise. + (gfc_charlen_t): New typedef. + (gfc_expr): Use gfc_charlen_t for character lengths. + (gfc_size_kind): New extern variable. + (gfc_extract_hwi): New prototype. + (gfc_get_character_expr): Use gfc_charlen_t for character length. + (gfc_get_int_expr): Use HOST_WIDE_INT type for value argument. + * gfortran.texi: Update description of hidden string length argument. + * iresolve.c (check_charlen_present): Use gfc_charlen_int_kind. + (gfc_resolve_char_achar): Likewise. + (gfc_resolve_repeat): Pass string length directly without + temporary, use gfc_charlen_int_kind. + (gfc_resolve_transfer): Use gfc_charlen_int_kind. + * match.c (select_intrinsic_set_tmp): Use HOST_WIDE_INT for charlen. + * misc.c (gfc_mpz_get_hwi): New function. + (gfc_mpz_set_hwi): New function. + * module.c (atom_int): Change type from int to HOST_WIDE_INT. + (parse_integer): Don't complain about large integers. + (write_atom): Use HOST_WIDE_INT for integers. + (mio_integer): Handle integer type mismatch. + (mio_hwi): New function. + (mio_intrinsic_op): Use HOST_WIDE_INT. + (mio_array_ref): Likewise. + (mio_expr): Likewise. + * primary.c (match_substring): Use gfc_charlen_int_kind. + * resolve.c (resolve_substring_charlen): Use gfc_charlen_int_kind. + (resolve_character_operator): Likewise. + (resolve_assoc_var): Likewise. + (resolve_select_type): Use HOST_WIDE_INT for charlen, use snprintf. + (resolve_charlen): Use mpz_sgn to determine sign. + * simplify.c (gfc_simplify_repeat): Use HOST_WIDE_INT/gfc_charlen_t + instead of long. + * symbol.c (generate_isocbinding_symbol): Use gfc_charlen_int_kind. + * target-memory.c (size_character): Length argument of type + gfc_charlen_t. + (gfc_encode_character): Likewise. + (gfc_interpret_character): Use gfc_charlen_t. + * target-memory.h (gfc_encode_character): Modify prototype. + * trans-array.c (gfc_trans_array_ctor_element): Use existing type. + (get_array_ctor_var_strlen): Use gfc_conv_mpz_to_tree_type. + (trans_array_constructor): Use existing type. + (get_array_charlen): Likewise. + * trans-const.c (gfc_conv_mpz_to_tree_type): New function. + * trans-const.h (gfc_conv_mpz_to_tree_type): New prototype. + * trans-decl.c (gfc_trans_deferred_vars): Use existing type. + (add_argument_checking): Likewise. + * trans-expr.c (gfc_class_len_or_zero_get): Build const of type + gfc_charlen_type_node. + (gfc_conv_intrinsic_to_class): Use gfc_charlen_int_kind instead of + 4, fold_convert to correct type. + (gfc_conv_class_to_class): Build const of type size_type_node for + size. + (gfc_copy_class_to_class): Likewise. + (gfc_conv_string_length): Use same type in expression. + (gfc_conv_substring): Likewise, use HOST_WIDE_INT for charlen. + (gfc_conv_string_tmp): Make sure len is of the right type. + (gfc_conv_concat_op): Use same type in expression. + (gfc_conv_procedure_call): Likewise. + (fill_with_spaces): Comment out memset() block due to spurious + -Wstringop-overflow warnings. + (gfc_trans_string_copy): Use gfc_charlen_type_node. + (alloc_scalar_allocatable_for_subcomponent_assignment): + fold_convert to right type. + (gfc_trans_subcomponent_assign): Likewise. + (trans_class_vptr_len_assignment): Build const of correct type. + (gfc_trans_pointer_assignment): Likewise. + (alloc_scalar_allocatable_for_assignment): fold_convert to right + type in expr. + (trans_class_assignment): Build const of correct type. + * trans-intrinsic.c (gfc_conv_associated): Likewise. + (gfc_conv_intrinsic_repeat): Do calculation in sizetype. + * trans-io.c (gfc_build_io_library_fndecls): Use + gfc_charlen_type_node for character lengths. + (set_string): Convert to right type in assignment. + * trans-stmt.c (gfc_trans_label_assign): Build const of + gfc_charlen_type_node. + (trans_associate_var): Likewise. + (gfc_trans_character_select): Likewise. + (gfc_trans_allocate): Likewise, don't typecast strlen result. + (gfc_trans_deallocate): Don't typecast strlen result. + * trans-types.c (gfc_size_kind): New variable. + (gfc_init_types): Determine gfc_charlen_int_kind and gfc_size_kind + from size_type_node. + * trans-types.h: Fix comment. + 2018-01-04 Thomas Koenig PR fortran/83683 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index fa252702e98..882fe577b76 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -2039,7 +2039,7 @@ got_charlen: gcc_assert (found_length != -1); /* Update the character length of the array constructor. */ - expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, found_length); } else diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index bb73ad1f386..50d25b550a1 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -35,7 +35,7 @@ along with GCC; see the file COPYING3. If not see * _vptr: A pointer to the vtable entry (see below) of the dynamic type. Only for unlimited polymorphic classes: - * _len: An integer(4) to store the string length when the unlimited + * _len: An integer(C_SIZE_T) to store the string length when the unlimited polymorphic pointer is used to point to a char array. The '_len' component will be zero when no character array is stored in '_data'. @@ -2317,13 +2317,13 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (!gfc_add_component (vtype, "_size", &c)) goto cleanup; c->ts.type = BT_INTEGER; - c->ts.kind = 4; + c->ts.kind = gfc_size_kind; c->attr.access = ACCESS_PRIVATE; /* Remember the derived type in ts.u.derived, so that the correct initializer can be set later on (in gfc_conv_structure). */ c->ts.u.derived = derived; - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + c->initializer = gfc_get_int_expr (gfc_size_kind, NULL, 0); /* Add component _extends. */ @@ -2685,7 +2685,7 @@ find_intrinsic_vtab (gfc_typespec *ts) if (!gfc_add_component (vtype, "_size", &c)) goto cleanup; c->ts.type = BT_INTEGER; - c->ts.kind = 4; + c->ts.kind = gfc_size_kind; c->attr.access = ACCESS_PRIVATE; /* Build a minimal expression to make use of @@ -2696,11 +2696,11 @@ find_intrinsic_vtab (gfc_typespec *ts) e = gfc_get_expr (); e->ts = *ts; e->expr_type = EXPR_VARIABLE; - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + c->initializer = gfc_get_int_expr (gfc_size_kind, NULL, ts->type == BT_CHARACTER ? ts->kind - : (int)gfc_element_size (e)); + : gfc_element_size (e)); gfc_free_expr (e); /* Add component _extends. */ diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 645d1b6e0fd..a944e4f721f 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -995,7 +995,7 @@ match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) if (obsolescent_check && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) return MATCH_ERROR; - *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length); + *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length); return m; } @@ -1702,7 +1702,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) if (sym->ts.u.cl->length == NULL) { - int clen; + gfc_charlen_t clen; /* If there are multiple CHARACTER variables declared on the same line, we don't want them to share the same length. */ sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -1713,7 +1713,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) { clen = init->value.character.length; sym->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, clen); } else if (init->expr_type == EXPR_ARRAY) @@ -1740,7 +1740,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) else gcc_unreachable (); sym->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, clen); } else if (init->ts.u.cl && init->ts.u.cl->length) @@ -3073,7 +3073,7 @@ done: cl = gfc_new_charlen (gfc_current_ns, NULL); if (seen_length == 0) - cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); else cl->length = len; @@ -4315,7 +4315,7 @@ gfc_match_implicit (void) { ts.kind = gfc_default_character_kind; ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); } diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index d40c97d39bd..c2c9b63c880 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -348,12 +348,10 @@ show_constructor (gfc_constructor_base base) static void -show_char_const (const gfc_char_t *c, int length) +show_char_const (const gfc_char_t *c, gfc_charlen_t length) { - int i; - fputc ('\'', dumpfile); - for (i = 0; i < length; i++) + for (size_t i = 0; i < (size_t) length; i++) { if (c[i] == '\'') fputs ("''", dumpfile); @@ -465,7 +463,8 @@ show_expr (gfc_expr *p) break; case BT_HOLLERITH: - fprintf (dumpfile, "%dH", p->representation.length); + fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H", + p->representation.length); c = p->representation.string; for (i = 0; i < p->representation.length; i++, c++) { diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 855688176ab..a8f0f0f9016 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "target-memory.h" /* for gfc_convert_boz */ #include "constructor.h" +#include "tree.h" /* The following set of functions provide access to gfc_expr* of @@ -184,7 +185,7 @@ gfc_get_constant_expr (bt type, int kind, locus *where) blanked and null-terminated. */ gfc_expr * -gfc_get_character_expr (int kind, locus *where, const char *src, int len) +gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) { gfc_expr *e; gfc_char_t *dest; @@ -210,13 +211,14 @@ gfc_get_character_expr (int kind, locus *where, const char *src, int len) /* Get a new expression node that is an integer constant. */ gfc_expr * -gfc_get_int_expr (int kind, locus *where, int value) +gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) { gfc_expr *p; p = gfc_get_constant_expr (BT_INTEGER, kind, where ? where : &gfc_current_locus); - mpz_set_si (p->value.integer, value); + const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); + wi::to_mpz (w, p->value.integer, SIGNED); return p; } @@ -672,6 +674,62 @@ gfc_extract_int (gfc_expr *expr, int *result, int report_error) } +/* Same as gfc_extract_int, but use a HWI. */ + +bool +gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) +{ + gfc_ref *ref; + + /* A KIND component is a parameter too. The expression for it is + stored in the initializer and should be consistent with the tests + below. */ + if (gfc_expr_attr(expr).pdt_kind) + { + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.pdt_kind) + expr = ref->u.c.component->initializer; + } + } + + if (expr->expr_type != EXPR_CONSTANT) + { + if (report_error > 0) + gfc_error ("Constant expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Constant expression required at %C"); + return true; + } + + if (expr->ts.type != BT_INTEGER) + { + if (report_error > 0) + gfc_error ("Integer expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Integer expression required at %C"); + return true; + } + + /* Use long_long_integer_type_node to determine when to saturate. */ + const wide_int val = wi::from_mpz (long_long_integer_type_node, + expr->value.integer, false); + + if (!wi::fits_shwi_p (val)) + { + if (report_error > 0) + gfc_error ("Integer value too large in expression at %C"); + else if (report_error < 0) + gfc_error_now ("Integer value too large in expression at %C"); + return true; + } + + *result = val.to_shwi (); + + return false; +} + + /* Recursively copy a list of reference structures. */ gfc_ref * @@ -1701,7 +1759,7 @@ simplify_const_ref (gfc_expr *p) a substring out of it, update the type-spec's character length according to the first element (as all should have the same length). */ - int string_len; + gfc_charlen_t string_len; if ((c = gfc_constructor_first (p->value.constructor))) { const gfc_expr* first = c->expr; @@ -1719,7 +1777,7 @@ simplify_const_ref (gfc_expr *p) gfc_free_expr (p->ts.u.cl->length); p->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, string_len); } } @@ -1870,18 +1928,18 @@ gfc_simplify_expr (gfc_expr *p, int type) if (gfc_is_constant_expr (p)) { gfc_char_t *s; - int start, end; + HOST_WIDE_INT start, end; start = 0; if (p->ref && p->ref->u.ss.start) { - gfc_extract_int (p->ref->u.ss.start, &start); + gfc_extract_hwi (p->ref->u.ss.start, &start); start--; /* Convert from one-based to zero-based. */ } end = p->value.character.length; if (p->ref && p->ref->u.ss.end) - gfc_extract_int (p->ref->u.ss.end, &end); + gfc_extract_hwi (p->ref->u.ss.end, &end); if (end < start) end = start; @@ -1894,7 +1952,7 @@ gfc_simplify_expr (gfc_expr *p, int type) p->value.character.string = s; p->value.character.length = end - start; p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, p->value.character.length); gfc_free_ref_list (p->ref); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 7bd5ab3ff39..bfa50bea766 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -2224,11 +2224,11 @@ optimize_trim (gfc_expr *e) /* Set the start of the reference. */ - ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); /* Build the function call to len_trim(x, gfc_default_integer_kind). */ - fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind); + fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind); /* Set the end of the reference to the call to len_trim. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f0c98c9b626..b3f8e423efe 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2092,6 +2092,14 @@ gfc_intrinsic_sym; typedef splay_tree gfc_constructor_base; + +/* This should be an unsigned variable of type size_t. But to handle + compiling to a 64-bit target from a 32-bit host, we need to use a + HOST_WIDE_INT. Also, occasionally the string length field is used + as a flag with values -1 and -2, see e.g. gfc_add_assign_aux_vars. + So it needs to be signed. */ +typedef HOST_WIDE_INT gfc_charlen_t; + typedef struct gfc_expr { expr_t expr_type; @@ -2137,7 +2145,7 @@ typedef struct gfc_expr the value. */ struct { - int length; + gfc_charlen_t length; char *string; } representation; @@ -2193,7 +2201,7 @@ typedef struct gfc_expr struct { - int length; + gfc_charlen_t length; gfc_char_t *string; } character; @@ -2809,6 +2817,9 @@ vec_push (char **&optr, size_t &osz, const char *elt) optr[++osz] = NULL; } +HOST_WIDE_INT gfc_mpz_get_hwi (mpz_t); +void gfc_mpz_set_hwi (mpz_t, const HOST_WIDE_INT); + /* options.c */ unsigned int gfc_option_lang_mask (void); void gfc_init_options_struct (struct gcc_options *); @@ -2900,6 +2911,7 @@ extern int gfc_atomic_int_kind; extern int gfc_atomic_logical_kind; extern int gfc_intio_kind; extern int gfc_charlen_int_kind; +extern int gfc_size_kind; extern int gfc_numeric_storage_size; extern int gfc_character_storage_size; @@ -3134,7 +3146,10 @@ void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *); /* expr.c */ void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); + bool gfc_extract_int (gfc_expr *, int *, int = 0); +bool gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *, int = 0); + bool is_subref_array (gfc_expr *); bool gfc_is_simply_contiguous (gfc_expr *, bool, bool); bool gfc_check_init_expr (gfc_expr *); @@ -3152,8 +3167,8 @@ gfc_expr *gfc_get_null_expr (locus *); gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *); gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *); gfc_expr *gfc_get_constant_expr (bt, int, locus *); -gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len); -gfc_expr *gfc_get_int_expr (int, locus *, int); +gfc_expr *gfc_get_character_expr (int, locus *, const char *, gfc_charlen_t len); +gfc_expr *gfc_get_int_expr (int, locus *, HOST_WIDE_INT); gfc_expr *gfc_get_logical_expr (int, locus *, bool); gfc_expr *gfc_get_iokind_expr (locus *, io_kind); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index a8fdf92aaa0..11246696e18 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -3925,12 +3925,42 @@ front ends of GCC, e.g. to GCC's C99 compiler for @code{_Bool} or GCC's Ada compiler for @code{Boolean}.) For arguments of @code{CHARACTER} type, the character length is passed -as hidden argument. For deferred-length strings, the value is passed -by reference, otherwise by value. The character length has the type -@code{INTEGER(kind=4)}. Note with C binding, @code{CHARACTER(len=1)} -result variables are returned according to the platform ABI and no -hidden length argument is used for dummy arguments; with @code{VALUE}, -those variables are passed by value. +as a hidden argument at the end of the argument list. For +deferred-length strings, the value is passed by reference, otherwise +by value. The character length has the C type @code{size_t} (or +@code{INTEGER(kind=C_SIZE_T)} in Fortran). Note that this is +different to older versions of the GNU Fortran compiler, where the +type of the hidden character length argument was a C @code{int}. In +order to retain compatibility with older versions, one can e.g. for +the following Fortran procedure + +@smallexample +subroutine fstrlen (s, a) + character(len=*) :: s + integer :: a + print*, len(s) +end subroutine fstrlen +@end smallexample + +define the corresponding C prototype as follows: + +@smallexample +#if __GNUC__ > 7 +typedef size_t fortran_charlen_t; +#else +typedef int fortran_charlen_t; +#endif + +void fstrlen_ (char*, int*, fortran_charlen_t); +@end smallexample + +In order to avoid such compiler-specific details, for new code it is +instead recommended to use the ISO_C_BINDING feature. + +Note with C binding, @code{CHARACTER(len=1)} result variables are +returned according to the platform ABI and no hidden length argument +is used for dummy arguments; with @code{VALUE}, those variables are +passed by value. For @code{OPTIONAL} dummy arguments, an absent argument is denoted by a NULL pointer, except for scalar dummy arguments of type diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 77cdce531d0..11f256919b9 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -82,7 +82,7 @@ check_charlen_present (gfc_expr *source) if (source->expr_type == EXPR_CONSTANT) { source->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, NULL, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, source->value.character.length); source->rank = 0; } @@ -90,7 +90,7 @@ check_charlen_present (gfc_expr *source) { gfc_constructor *c = gfc_constructor_first (source->value.constructor); source->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, NULL, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, c->expr->value.character.length); } } @@ -247,7 +247,7 @@ gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, f->ts.kind = (kind == NULL) ? gfc_default_character_kind : mpz_get_si (kind->value.integer); f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); f->value.function.name = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind, @@ -2243,7 +2243,6 @@ void gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, gfc_expr *ncopies) { - int len; gfc_expr *tmp; f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; @@ -2256,8 +2255,8 @@ gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, tmp = NULL; if (string->expr_type == EXPR_CONSTANT) { - len = string->value.character.length; - tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len); + tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + string->value.character.length); } else if (string->ts.u.cl && string->ts.u.cl->length) { @@ -3023,14 +3022,14 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, if (mold->expr_type == EXPR_CONSTANT) { len = mold->value.character.length; - mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, len); } else { gfc_constructor *c = gfc_constructor_first (mold->value.constructor); len = c->expr->value.character.length; - mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, len); } } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index d7fb9330ca4..5e313c41fcf 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5878,7 +5878,7 @@ select_intrinsic_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; - int charlen = 0; + HOST_WIDE_INT charlen = 0; if (ts->type == BT_CLASS || ts->type == BT_DERIVED) return NULL; @@ -5889,14 +5889,14 @@ select_intrinsic_set_tmp (gfc_typespec *ts) if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (ts->u.cl->length->value.integer); + charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (ts->type != BT_CHARACTER) sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), ts->kind); else - sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type), - charlen, ts->kind); + snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (ts->type), charlen, ts->kind); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 8e789e52570..80d282efd07 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "gfortran.h" #include "spellcheck.h" +#include "tree.h" /* Initialize a typespec to unknown. */ @@ -321,3 +322,23 @@ gfc_closest_fuzzy_match (const char *typo, char **candidates) } return best; } + +/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */ + +HOST_WIDE_INT +gfc_mpz_get_hwi (mpz_t op) +{ + /* Using long_long_integer_type_node as that is the integer type + node that closest matches HOST_WIDE_INT; both are guaranteed to + be at least 64 bits. */ + const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true); + return w.to_shwi (); +} + + +void +gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) +{ + const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); + wi::to_mpz (w, rop, SIGNED); +} diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 4c5cefb82aa..b120501beb7 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -143,7 +143,7 @@ enum gfc_wsym_state typedef struct pointer_info { BBT_HEADER (pointer_info); - int integer; + HOST_WIDE_INT integer; pointer_t type; /* The first component of each member of the union is the pointer @@ -368,7 +368,7 @@ get_pointer (void *gp) creating the node if not found. */ static pointer_info * -get_integer (int integer) +get_integer (HOST_WIDE_INT integer) { pointer_info *p, t; int c; @@ -468,7 +468,7 @@ associate_integer_pointer (pointer_info *p, void *gp) sometime later. Returns the pointer_info structure. */ static pointer_info * -add_fixup (int integer, void *gp) +add_fixup (HOST_WIDE_INT integer, void *gp) { pointer_info *p; fixup_t *f; @@ -1145,7 +1145,7 @@ static atom_type last_atom; #define MAX_ATOM_SIZE 100 -static int atom_int; +static HOST_WIDE_INT atom_int; static char *atom_string, atom_name[MAX_ATOM_SIZE]; @@ -1275,7 +1275,7 @@ parse_string (void) } -/* Parse a small integer. */ +/* Parse an integer. Should fit in a HOST_WIDE_INT. */ static void parse_integer (int c) @@ -1292,8 +1292,6 @@ parse_integer (int c) } atom_int = 10 * atom_int + c - '0'; - if (atom_int > 99999999) - bad_module ("Integer overflow"); } } @@ -1635,11 +1633,12 @@ write_char (char out) static void write_atom (atom_type atom, const void *v) { - char buffer[20]; + char buffer[32]; /* Workaround -Wmaybe-uninitialized false positive during profiledbootstrap by initializing them. */ - int i = 0, len; + int len; + HOST_WIDE_INT i = 0; const char *p; switch (atom) @@ -1658,11 +1657,9 @@ write_atom (atom_type atom, const void *v) break; case ATOM_INTEGER: - i = *((const int *) v); - if (i < 0) - gfc_internal_error ("write_atom(): Writing negative integer"); + i = *((const HOST_WIDE_INT *) v); - sprintf (buffer, "%d", i); + snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); p = buffer; break; @@ -1770,7 +1767,10 @@ static void mio_integer (int *ip) { if (iomode == IO_OUTPUT) - write_atom (ATOM_INTEGER, ip); + { + HOST_WIDE_INT hwi = *ip; + write_atom (ATOM_INTEGER, &hwi); + } else { require_atom (ATOM_INTEGER); @@ -1778,6 +1778,18 @@ mio_integer (int *ip) } } +static void +mio_hwi (HOST_WIDE_INT *hwi) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_INTEGER, hwi); + else + { + require_atom (ATOM_INTEGER); + *hwi = atom_int; + } +} + /* Read or write a gfc_intrinsic_op value. */ @@ -1787,7 +1799,7 @@ mio_intrinsic_op (gfc_intrinsic_op* op) /* FIXME: Would be nicer to do this via the operators symbolic name. */ if (iomode == IO_OUTPUT) { - int converted = (int) *op; + HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; write_atom (ATOM_INTEGER, &converted); } else @@ -2719,7 +2731,7 @@ mio_array_ref (gfc_array_ref *ar) { for (i = 0; i < ar->dimen; i++) { - int tmp = (int)ar->dimen_type[i]; + HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; write_atom (ATOM_INTEGER, &tmp); } } @@ -2756,7 +2768,8 @@ mio_pointer_ref (void *gp) if (iomode == IO_OUTPUT) { p = get_pointer (*((char **) gp)); - write_atom (ATOM_INTEGER, &p->integer); + HOST_WIDE_INT hwi = p->integer; + write_atom (ATOM_INTEGER, &hwi); } else { @@ -2794,18 +2807,18 @@ static void mio_component (gfc_component *c, int vtype) { pointer_info *p; - int n; mio_lparen (); if (iomode == IO_OUTPUT) { p = get_pointer (c); - mio_integer (&p->integer); + mio_hwi (&p->integer); } else { - mio_integer (&n); + HOST_WIDE_INT n; + mio_hwi (&n); p = get_integer (n); associate_integer_pointer (p, c); } @@ -3430,6 +3443,7 @@ fix_mio_expr (gfc_expr *e) static void mio_expr (gfc_expr **ep) { + HOST_WIDE_INT hwi; gfc_expr *e; atom_type t; int flag; @@ -3644,7 +3658,9 @@ mio_expr (gfc_expr **ep) break; case BT_CHARACTER: - mio_integer (&e->value.character.length); + hwi = e->value.character.length; + mio_hwi (&hwi); + e->value.character.length = hwi; e->value.character.string = CONST_CAST (gfc_char_t *, mio_allocated_wide_string (e->value.character.string, @@ -5946,7 +5962,7 @@ write_symtree (gfc_symtree *st) mio_pool_string (&st->name); mio_integer (&st->ambiguous); - mio_integer (&p->integer); + mio_hwi (&p->integer); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 51c3a46b2b9..4b6ad47d75a 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -862,7 +862,7 @@ match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred) ref->type = REF_SUBSTRING; if (start == NULL) - start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); ref->u.ss.start = start; if (end == NULL && cl) end = gfc_copy_expr (cl->length); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 925cffea84b..57155cddf68 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4901,7 +4901,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); else - start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); if (char_ref->u.ss.end) end = gfc_copy_expr (char_ref->u.ss.end); @@ -4924,7 +4924,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) /* Length = (end - start + 1). */ e->ts.u.cl->length = gfc_subtract (end, start); e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, - gfc_get_int_expr (gfc_default_integer_kind, + gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1)); /* F2008, 6.4.1: Both the starting point and the ending point shall @@ -5690,13 +5690,13 @@ gfc_resolve_character_operator (gfc_expr *e) if (op1->ts.u.cl && op1->ts.u.cl->length) e1 = gfc_copy_expr (op1->ts.u.cl->length); else if (op1->expr_type == EXPR_CONSTANT) - e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, op1->value.character.length); if (op2->ts.u.cl && op2->ts.u.cl->length) e2 = gfc_copy_expr (op2->ts.u.cl->length); else if (op2->expr_type == EXPR_CONSTANT) - e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, op2->value.character.length); e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -8630,7 +8630,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!sym->ts.u.cl->length && !sym->ts.deferred && target->expr_type == EXPR_CONSTANT) sym->ts.u.cl->length - = gfc_get_int_expr (gfc_default_integer_kind, + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, target->value.character.length); } @@ -8715,7 +8715,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; int error = 0; - int charlen = 0; int rank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; @@ -8966,11 +8965,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); else if (c->ts.type == BT_CHARACTER) { + HOST_WIDE_INT charlen = 0; if (c->ts.u.cl && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (c->ts.u.cl->length->value.integer); - sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type), - charlen, c->ts.kind); + charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); + snprintf (name, sizeof (name), + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind); } else sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), @@ -11640,7 +11641,7 @@ resolve_index_expr (gfc_expr *e) static bool resolve_charlen (gfc_charlen *cl) { - int i, k; + int k; bool saved_specification_expr; if (cl->resolved) @@ -11676,9 +11677,10 @@ resolve_charlen (gfc_charlen *cl) /* F2008, 4.4.3.2: If the character length parameter value evaluates to a negative value, the length of character entities declared is zero. */ - if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0) + if (cl->length && cl->length->expr_type == EXPR_CONSTANT + && mpz_sgn (cl->length->value.integer) < 0) gfc_replace_expr (cl->length, - gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); + gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); /* Check that the character length is not too large. */ k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); @@ -15962,7 +15964,7 @@ resolve_equivalence (gfc_equiv *eq) { ref->type = REF_SUBSTRING; if (start == NULL) - start = gfc_get_int_expr (gfc_default_integer_kind, + start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); ref->u.ss.start = start; if (end == NULL && e->ts.u.cl) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index bf8a5397c45..3e5abd44cc6 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -5982,7 +5982,7 @@ gfc_expr * gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) { gfc_expr *result; - int i, j, len, ncop, nlen; + gfc_charlen_t len; mpz_t ncopies; bool have_length = false; @@ -6002,7 +6002,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (e->ts.u.cl && e->ts.u.cl->length && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - len = mpz_get_si (e->ts.u.cl->length->value.integer); + len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); have_length = true; } else if (e->expr_type == EXPR_CONSTANT @@ -6038,7 +6038,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) } else { - mpz_init_set_si (mlen, len); + mpz_init (mlen); + gfc_mpz_set_hwi (mlen, len); mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); mpz_clear (mlen); } @@ -6062,11 +6063,12 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (e->expr_type != EXPR_CONSTANT) return NULL; + HOST_WIDE_INT ncop; if (len || (e->ts.u.cl->length && mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) { - bool fail = gfc_extract_int (n, &ncop); + bool fail = gfc_extract_hwi (n, &ncop); gcc_assert (!fail); } else @@ -6076,11 +6078,18 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); len = e->value.character.length; - nlen = ncop * len; + gfc_charlen_t nlen = ncop * len; + + /* Here's a semi-arbitrary limit. If the string is longer than 32 MB + (8 * 2**20 elements * 4 bytes (wide chars) per element) defer to + runtime instead of consuming (unbounded) memory and CPU at + compile time. */ + if (nlen > 8388608) + return NULL; result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); - for (i = 0; i < ncop; i++) - for (j = 0; j < len; j++) + for (size_t i = 0; i < (size_t) ncop; i++) + for (size_t j = 0; j < (size_t) len; j++) result->value.character.string[j+i*len]= e->value.character.string[j]; result->value.character.string[nlen] = '\0'; /* For debugger */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8a206e60bac..344c644bac9 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4856,7 +4856,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->value->value.character.string[0] = (gfc_char_t) c_interop_kinds_table[s].value; tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); /* May not need this in both attr and ts, but do need in diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index d596ca3b9c4..c708b17da39 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -65,7 +65,7 @@ size_logical (int kind) static size_t -size_character (int length, int kind) +size_character (gfc_charlen_t length, int kind) { int i = gfc_validate_kind (BT_CHARACTER, kind, false); return length * gfc_character_kinds[i].bit_size / 8; @@ -97,9 +97,9 @@ gfc_element_size (gfc_expr *e) && e->ts.u.cl->length->expr_type == EXPR_CONSTANT && e->ts.u.cl->length->ts.type == BT_INTEGER) { - int length; + HOST_WIDE_INT length; - gfc_extract_int (e->ts.u.cl->length, &length); + gfc_extract_hwi (e->ts.u.cl->length, &length); return size_character (length, e->ts.kind); } else @@ -217,16 +217,15 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size int -gfc_encode_character (int kind, int length, const gfc_char_t *string, +gfc_encode_character (int kind, gfc_charlen_t length, const gfc_char_t *string, unsigned char *buffer, size_t buffer_size) { size_t elsize = size_character (1, kind); tree type = gfc_get_char_type (kind); - int i; gcc_assert (buffer_size >= size_character (length, kind)); - for (i = 0; i < length; i++) + for (size_t i = 0; i < (size_t) length; i++) native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], elsize); @@ -438,11 +437,9 @@ int gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { - int i; - if (result->ts.u.cl && result->ts.u.cl->length) result->value.character.length = - (int) mpz_get_ui (result->ts.u.cl->length->value.integer); + gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer); gcc_assert (buffer_size >= size_character (result->value.character.length, result->ts.kind)); @@ -450,7 +447,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_get_wide_string (result->value.character.length + 1); if (result->ts.kind == gfc_default_character_kind) - for (i = 0; i < result->value.character.length; i++) + for (size_t i = 0; i < (size_t) result->value.character.length; i++) result->value.character.string[i] = (gfc_char_t) buffer[i]; else { @@ -459,7 +456,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size, mpz_init (integer); gcc_assert (bytes <= sizeof (unsigned long)); - for (i = 0; i < result->value.character.length; i++) + for (size_t i = 0; i < (size_t) result->value.character.length; i++) { gfc_conv_tree_to_mpz (integer, native_interpret_expr (gfc_get_char_type (result->ts.kind), diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 488a7c70d8d..a9141a66885 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -28,7 +28,7 @@ size_t gfc_element_size (gfc_expr *); size_t gfc_target_expr_size (gfc_expr *); /* Write a constant expression in binary form to a target buffer. */ -int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *, +int gfc_encode_character (int, gfc_charlen_t, const gfc_char_t *, unsigned char *, size_t); unsigned HOST_WIDE_INT gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 07d9e8500e3..b8e31bb6dff 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1537,8 +1537,8 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); esize = fold_convert (gfc_charlen_type_node, esize); esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_charlen_type_node, esize, - build_int_cst (gfc_charlen_type_node, + TREE_TYPE (esize), esize, + build_int_cst (TREE_TYPE (esize), gfc_character_kinds[i].bit_size / 8)); gfc_conv_string_parameter (se); @@ -2059,8 +2059,7 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) mpz_init_set_ui (char_len, 1); mpz_add (char_len, char_len, ref->u.ss.end->value.integer); mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); - *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind); - *len = convert (gfc_charlen_type_node, *len); + *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); mpz_clear (char_len); return; @@ -2428,7 +2427,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) set LEN = 0. */ neg_len = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ss_info->string_length, - build_int_cst (gfc_charlen_type_node, 0)); + build_zero_cst (TREE_TYPE + (ss_info->string_length))); /* Print a warning if bounds checking is enabled. */ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { @@ -2441,7 +2441,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) ss_info->string_length = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, neg_len, - build_int_cst (gfc_charlen_type_node, 0), + build_zero_cst + (TREE_TYPE (ss_info->string_length)), ss_info->string_length); ss_info->string_length = gfc_evaluate_now (ss_info->string_length, &length_se.pre); @@ -6878,8 +6879,8 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) gfc_add_block_to_block (&se->post, &tse.post); tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); tse.expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_charlen_type_node, tse.expr, - build_int_cst (gfc_charlen_type_node, 0)); + TREE_TYPE (tse.expr), tse.expr, + build_zero_cst (TREE_TYPE (tse.expr))); expr->ts.u.cl->backend_decl = tse.expr; gfc_free_interface_mapping (&mapping); break; diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 1990fff1e1f..028e6d2cedb 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -206,6 +206,18 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind) return wide_int_to_tree (gfc_get_int_type (kind), val); } + +/* Convert a GMP integer into a tree node of type given by the type + argument. */ + +tree +gfc_conv_mpz_to_tree_type (mpz_t i, const tree type) +{ + const wide_int val = wi::from_mpz (type, i, true); + return wide_int_to_tree (type, val); +} + + /* Converts a backend tree into a GMP integer. */ void diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h index 775ab9e7f8d..39693bb7cf7 100644 --- a/gcc/fortran/trans-const.h +++ b/gcc/fortran/trans-const.h @@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see /* Converts between INT_CST and GMP integer representations. */ tree gfc_conv_mpz_to_tree (mpz_t, int); +tree gfc_conv_mpz_to_tree_type (mpz_t, const tree); void gfc_conv_tree_to_mpz (mpz_t, tree); /* Converts between REAL_CST and MPFR floating-point representations. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index b3cbf533dbe..144a3447769 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4280,10 +4280,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) { tmp = proc_sym->ts.u.cl->passed_length; tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = fold_convert (gfc_charlen_type_node, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, - gfc_charlen_type_node, tmp, - proc_sym->ts.u.cl->backend_decl); + TREE_TYPE (tmp), tmp, + fold_convert + (TREE_TYPE (tmp), + proc_sym->ts.u.cl->backend_decl)); } else tmp = NULL_TREE; @@ -5840,7 +5841,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) not_0length = fold_build2_loc (input_location, NE_EXPR, logical_type_node, cl->passed_length, - build_zero_cst (gfc_charlen_type_node)); + build_zero_cst + (TREE_TYPE (cl->passed_length))); /* The symbol needs to be referenced for gfc_get_symbol_decl. */ fsym->attr.referenced = 1; not_absent = gfc_conv_expr_present (fsym); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 58414b16eb5..533435ae0c3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -250,7 +250,7 @@ gfc_class_len_or_zero_get (tree decl) return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (len), decl, len, NULL_TREE) - : integer_zero_node; + : build_zero_cst (gfc_charlen_type_node); } @@ -884,7 +884,8 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, { /* Amazingly all data is present to compute the length of a constant string, but the expression is not yet there. */ - e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4, + e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, + gfc_charlen_int_kind, &e->where); mpz_set_ui (e->ts.u.cl->length->value.integer, e->value.character.length); @@ -902,7 +903,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, else tmp = integer_zero_node; - gfc_add_modify (&parmse->pre, ctree, tmp); + gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); } else if (class_ts.type == BT_CLASS && class_ts.u.derived->components @@ -1045,7 +1046,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); - slen = integer_zero_node; + slen = build_zero_cst (size_type_node); } else { @@ -1096,7 +1097,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = slen; } else - tmp = integer_zero_node; + tmp = build_zero_cst (size_type_node); gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); @@ -1235,7 +1236,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) if (from != NULL_TREE && unlimited) from_len = gfc_class_len_or_zero_get (from); else - from_len = integer_zero_node; + from_len = build_zero_cst (size_type_node); } if (GFC_CLASS_TYPE_P (TREE_TYPE (to))) @@ -1347,7 +1348,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, from_len, - integer_zero_node); + build_zero_cst (TREE_TYPE (from_len))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, extcopy, stdcopy); gfc_add_expr_to_block (&body, tmp); @@ -1375,7 +1376,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) extcopy = build_call_vec (fcn_type, fcn, args); tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, from_len, - integer_zero_node); + build_zero_cst (TREE_TYPE (from_len))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, extcopy, stdcopy); } @@ -2206,7 +2207,7 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, - se.expr, build_int_cst (gfc_charlen_type_node, 0)); + se.expr, build_zero_cst (TREE_TYPE (se.expr))); gfc_add_block_to_block (pblock, &se.pre); if (cl->backend_decl) @@ -2278,7 +2279,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* Check lower bound. */ fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, start.expr, - build_int_cst (gfc_charlen_type_node, 1)); + build_one_cst (TREE_TYPE (start.expr))); fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, logical_type_node, nonempty, fault); if (name) @@ -2314,9 +2315,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, if (ref->u.ss.end && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) { - int i_len; + HOST_WIDE_INT i_len; - i_len = mpz_get_si (length) + 1; + i_len = gfc_mpz_get_hwi (length) + 1; if (i_len < 0) i_len = 0; @@ -2326,7 +2327,8 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, else { tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, - end.expr, start.expr); + fold_convert (gfc_charlen_type_node, end.expr), + fold_convert (gfc_charlen_type_node, start.expr)); tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, build_int_cst (gfc_charlen_type_node, 1), tmp); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, @@ -3129,9 +3131,9 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Create a temporary variable to hold the result. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_charlen_type_node, len, - build_int_cst (gfc_charlen_type_node, 1)); - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); + TREE_TYPE (len), len, + build_int_cst (TREE_TYPE (len), 1)); + tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp); if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); @@ -3193,8 +3195,11 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) if (len == NULL_TREE) { len = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (lse.string_length), - lse.string_length, rse.string_length); + gfc_charlen_type_node, + fold_convert (gfc_charlen_type_node, + lse.string_length), + fold_convert (gfc_charlen_type_node, + rse.string_length)); } type = build_pointer_type (type); @@ -5920,11 +5925,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); - - tmp = fold_convert (gfc_charlen_type_node, parmse.expr); + tmp = parmse.expr; tmp = fold_build2_loc (input_location, MAX_EXPR, - gfc_charlen_type_node, tmp, - build_int_cst (gfc_charlen_type_node, 0)); + TREE_TYPE (tmp), tmp, + build_zero_cst (TREE_TYPE (tmp))); cl.backend_decl = tmp; } @@ -6403,13 +6407,16 @@ fill_with_spaces (tree start, tree type, tree size) tree i, el, exit_label, cond, tmp; /* For a simple char type, we can call memset(). */ + /* TODO: This code does work and is potentially more efficient, but + causes spurious -Wstringop-overflow warnings. if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) return build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMSET), 3, start, build_int_cst (gfc_get_int_type (gfc_c_int_kind), lang_hooks.to_target_charset (' ')), - size); + fold_convert (size_type_node, size)); + */ /* Otherwise, we use a loop: for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type)) @@ -6485,23 +6492,23 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (slength != NULL_TREE) { - slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); + slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block); ssc = gfc_string_to_single_character (slen, src, skind); } else { - slen = build_int_cst (size_type_node, 1); + slen = build_one_cst (gfc_charlen_type_node); ssc = src; } if (dlength != NULL_TREE) { - dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); + dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block); dsc = gfc_string_to_single_character (dlen, dest, dkind); } else { - dlen = build_int_cst (size_type_node, 1); + dlen = build_one_cst (gfc_charlen_type_node); dsc = dest; } @@ -6524,18 +6531,18 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* Do nothing if the destination length is zero. */ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen, - build_int_cst (size_type_node, 0)); + build_zero_cst (TREE_TYPE (dlen))); /* For non-default character kinds, we have to multiply the string length by the base type size. */ chartype = gfc_get_char_type (dkind); - slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, slen), - fold_convert (size_type_node, + slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen), + slen, + fold_convert (TREE_TYPE (slen), TYPE_SIZE_UNIT (chartype))); - dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, dlen), - fold_convert (size_type_node, + dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen), + dlen, + fold_convert (TREE_TYPE (dlen), TYPE_SIZE_UNIT (chartype))); if (dlength && POINTER_TYPE_P (TREE_TYPE (dest))) @@ -6553,7 +6560,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, slen); tmp2 = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMMOVE), - 3, dest, src, tmp2); + 3, dest, src, + fold_convert (size_type_node, tmp2)); stmtblock_t tmpblock2; gfc_init_block (&tmpblock2); gfc_add_expr_to_block (&tmpblock2, tmp2); @@ -7264,7 +7272,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) /* Update the lhs character length. */ - gfc_add_modify (block, lhs_cl_size, size); + gfc_add_modify (block, lhs_cl_size, + fold_convert (TREE_TYPE (lhs_cl_size), size)); } @@ -7503,7 +7512,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, 1, size); gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), tmp)); - gfc_add_modify (&block, strlen, se.string_length); + gfc_add_modify (&block, strlen, + fold_convert (TREE_TYPE (strlen), se.string_length)); tmp = gfc_build_memcpy_call (dest, se.expr, size); gfc_add_expr_to_block (&block, tmp); } @@ -8174,7 +8184,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, from_len = gfc_evaluate_now (se.expr, block); } else - from_len = integer_zero_node; + from_len = build_zero_cst (gfc_charlen_type_node); } gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len), from_len)); @@ -8385,7 +8395,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&block, lse.string_length, rse.string_length); else if (lse.string_length != NULL) gfc_add_modify (&block, lse.string_length, - build_int_cst (gfc_charlen_type_node, 0)); + build_zero_cst (TREE_TYPE (lse.string_length))); } gfc_add_modify (&block, lse.expr, @@ -9643,7 +9653,9 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - lse.string_length, size); + lse.string_length, + fold_convert (TREE_TYPE (lse.string_length), + size)); /* Jump past the realloc if the lengths are the same. */ tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label2), @@ -9660,7 +9672,8 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, /* Update the lhs character length. */ size = string_length; - gfc_add_modify (block, lse.string_length, size); + gfc_add_modify (block, lse.string_length, + fold_convert (TREE_TYPE (lse.string_length), size)); } } @@ -9842,7 +9855,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, from_len, - integer_zero_node); + build_zero_cst (TREE_TYPE (from_len))); return fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, extcopy, stdcopy); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a1e6691c786..7fe8286a0a9 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7600,7 +7600,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) nonzero_charlen = fold_build2_loc (input_location, NE_EXPR, logical_type_node, arg1->expr->ts.u.cl->backend_decl, - integer_zero_node); + build_zero_cst + (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl))); if (scalar) { /* A pointer to a scalar. */ @@ -7890,11 +7891,11 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* We store in charsize the size of a character. */ i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); - size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8); + size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8); /* Get the arguments. */ gfc_conv_intrinsic_function_args (se, expr, args, 3); - slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre)); + slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre)); src = args[1]; ncopies = gfc_evaluate_now (args[2], &se->pre); ncopies_type = TREE_TYPE (ncopies); @@ -7911,7 +7912,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) is valid, and nothing happens. */ n = gfc_create_var (ncopies_type, "ncopies"); cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, - build_int_cst (size_type_node, 0)); + size_zero_node); tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, build_int_cst (ncopies_type, 0), ncopies); gfc_add_modify (&se->pre, n, tmp); @@ -7921,17 +7922,17 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) (or equal to) MAX / slen, where MAX is the maximal integer of the gfc_charlen_type_node type. If slen == 0, we need a special case to avoid the division by zero. */ - i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); - max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind); - max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, - fold_convert (size_type_node, max), slen); - largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type) - ? size_type_node : ncopies_type; + max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype, + fold_convert (sizetype, + TYPE_MAX_VALUE (gfc_charlen_type_node)), + slen); + largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type) + ? sizetype : ncopies_type; cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, fold_convert (largest, ncopies), fold_convert (largest, max)); tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, - build_int_cst (size_type_node, 0)); + size_zero_node); cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp, logical_false_node, cond); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -7948,8 +7949,8 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) for (i = 0; i < ncopies; i++) memmove (dest + (i * slen * size), src, slen*size); */ gfc_start_block (&block); - count = gfc_create_var (ncopies_type, "count"); - gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0)); + count = gfc_create_var (sizetype, "count"); + gfc_add_modify (&block, count, size_zero_node); exit_label = gfc_build_label_decl (NULL_TREE); /* Start the loop body. */ @@ -7957,7 +7958,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* Exit the loop if count >= ncopies. */ cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count, - ncopies); + fold_convert (sizetype, ncopies)); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, @@ -7965,25 +7966,22 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&body, tmp); /* Call memmove (dest + (i*slen*size), src, slen*size). */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, - fold_convert (gfc_charlen_type_node, slen), - fold_convert (gfc_charlen_type_node, count)); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, - tmp, fold_convert (gfc_charlen_type_node, size)); + tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen, + count); + tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp, + size); tmp = fold_build_pointer_plus_loc (input_location, fold_convert (pvoid_type_node, dest), tmp); tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMMOVE), 3, tmp, src, fold_build2_loc (input_location, MULT_EXPR, - size_type_node, slen, - fold_convert (size_type_node, - size))); + size_type_node, slen, size)); gfc_add_expr_to_block (&body, tmp); /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type, - count, build_int_cst (TREE_TYPE (count), 1)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype, + count, size_one_node); gfc_add_modify (&body, count, tmp); /* Build the loop. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 306743b2e27..9eb77e5986d 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -345,11 +345,11 @@ gfc_build_io_library_fndecls (void) iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("transfer_character")), ".wW", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("transfer_character_write")), ".wR", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("transfer_character_wide")), ".wW", @@ -852,7 +852,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_conv_string_parameter (&se); gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); - gfc_add_modify (&se.pre, len, se.string_length); + gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), + se.string_length)); } gfc_add_block_to_block (block, &se.pre); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 8220961ab73..74974d38096 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -112,7 +112,7 @@ gfc_trans_label_assign (gfc_code * code) || code->label1->defined == ST_LABEL_DO_TARGET) { label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); - len_tree = integer_minus_one_node; + len_tree = build_int_cst (gfc_charlen_type_node, -1); } else { @@ -125,7 +125,7 @@ gfc_trans_label_assign (gfc_code * code) label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); } - gfc_add_modify (&se.pre, len, len_tree); + gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); gfc_add_modify (&se.pre, addr, label_tree); return gfc_finish_block (&se.pre); @@ -1600,7 +1600,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && se.string_length != sym->ts.u.cl->backend_decl) { gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, - fold_convert (gfc_charlen_type_node, + fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), se.string_length)); } @@ -1777,7 +1777,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && se.string_length != sym->ts.u.cl->backend_decl) { gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, - fold_convert (gfc_charlen_type_node, + fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), se.string_length)); if (e->expr_type == EXPR_FUNCTION) { @@ -2838,7 +2838,7 @@ gfc_trans_character_select (gfc_code *code) { for (d = cp; d; d = d->right) { - int i; + gfc_charlen_t i; if (d->low) { gcc_assert (d->low->expr_type == EXPR_CONSTANT @@ -3043,7 +3043,7 @@ gfc_trans_character_select (gfc_code *code) if (d->low == NULL) { CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); - CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); } else { @@ -3056,7 +3056,7 @@ gfc_trans_character_select (gfc_code *code) if (d->high == NULL) { CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); - CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); } else { @@ -5747,7 +5747,7 @@ gfc_trans_allocate (gfc_code * code) { gfc_init_se (&se, NULL); temp_var_needed = false; - expr3_len = integer_zero_node; + expr3_len = build_zero_cst (gfc_charlen_type_node); e3_is = E3_MOLD; } /* Prevent aliasing, i.e., se.expr may be already a @@ -6152,7 +6152,8 @@ gfc_trans_allocate (gfc_code * code) e.g., a string. */ memsz = fold_build2_loc (input_location, GT_EXPR, logical_type_node, expr3_len, - integer_zero_node); + build_zero_cst + (TREE_TYPE (expr3_len))); memsz = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (expr3_esize), memsz, tmp, expr3_esize); @@ -6521,7 +6522,7 @@ gfc_trans_allocate (gfc_code * code) gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); + slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); dlen = gfc_get_expr_charlen (code->expr2); slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, slen); @@ -6818,7 +6819,7 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); + slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); dlen = gfc_get_expr_charlen (code->expr2); gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 16d851e49da..abcbf957e5d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -123,6 +123,9 @@ int gfc_intio_kind; /* The integer kind used to store character lengths. */ int gfc_charlen_int_kind; +/* Kind of internal integer for storing object sizes. */ +int gfc_size_kind; + /* The size of the numeric storage unit and character storage unit. */ int gfc_numeric_storage_size; int gfc_character_storage_size; @@ -1006,14 +1009,17 @@ gfc_init_types (void) wi::mask (n, UNSIGNED, TYPE_PRECISION (size_type_node))); - logical_type_node = gfc_get_logical_type (gfc_default_logical_kind); logical_true_node = build_int_cst (logical_type_node, 1); logical_false_node = build_int_cst (logical_type_node, 0); - /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */ - gfc_charlen_int_kind = 4; + /* Character lengths are of type size_t, except signed. */ + gfc_charlen_int_kind = get_int_kind_from_node (size_type_node); gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); + + /* Fortran kind number of size_type_node (size_t). This is used for + the _size member in vtables. */ + gfc_size_kind = get_int_kind_from_node (size_type_node); } /* Get the type node for the given type and kind. */ diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index fe1e1abebf2..99798ab617c 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_BACKEND_H #define GFC_BACKEND_H + extern GTY(()) tree gfc_array_index_type; extern GTY(()) tree gfc_array_range_type; extern GTY(()) tree gfc_character1_type_node; @@ -49,10 +50,9 @@ extern GTY(()) tree logical_false_node; /* This is the type used to hold the lengths of character variables. It must be the same as the corresponding definition in gfortran.h. */ -/* TODO: This is still hardcoded as kind=4 in some bits of the compiler - and runtime library. */ extern GTY(()) tree gfc_charlen_type_node; + /* The following flags give us information on the correspondence of real (and complex) kinds with C floating-point types long double and __float128. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 314cce716fe..1d3603a34f9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2018-01-05 Janne Blomqvist + + PR fortran/78534 + PR fortran/66310 + * gfortran.dg/char_cast_1.f90: Update scan pattern. + * gfortran.dg/dependency_49.f90: Likewise. + * gfortran.dg/repeat_4.f90: Use integers of kind C_SIZE_T. + * gfortran.dg/repeat_7.f90: New test for PR 66310. + * gfortran.dg/scan_2.f90: Handle potential cast in assignment. + * gfortran.dg/string_1.f90: Limit to ilp32 targets. + * gfortran.dg/string_1_lp64.f90: New test. + * gfortran.dg/string_3.f90: Limit to ilp32 targets. + * gfortran.dg/string_3_lp64.f90: New test. + 2018-01-05 Jakub Jelinek PR target/83604 diff --git a/gcc/testsuite/gfortran.dg/char_cast_1.f90 b/gcc/testsuite/gfortran.dg/char_cast_1.f90 index 02e695d2d7b..70963bbf0e6 100644 --- a/gcc/testsuite/gfortran.dg/char_cast_1.f90 +++ b/gcc/testsuite/gfortran.dg/char_cast_1.f90 @@ -25,6 +25,6 @@ return end function Upper end -! The sign that all is well is that [S.6][1] appears twice. -! Platform dependent variations are [S$6][1], [__S_6][1], [S___6][1] -! { dg-final { scan-tree-dump-times "6\\\]\\\[1\\\]" 2 "original" } } +! The sign that all is well is that [S.10][1] appears twice. +! Platform dependent variations are [S$10][1], [__S_10][1], [S___10][1] +! { dg-final { scan-tree-dump-times "10\\\]\\\[1\\\]" 2 "original" } } diff --git a/gcc/testsuite/gfortran.dg/dependency_49.f90 b/gcc/testsuite/gfortran.dg/dependency_49.f90 index 43ee284169f..73d517e8f76 100644 --- a/gcc/testsuite/gfortran.dg/dependency_49.f90 +++ b/gcc/testsuite/gfortran.dg/dependency_49.f90 @@ -11,4 +11,4 @@ program main a%x = a%x(2:3) print *,a%x end program main -! { dg-final { scan-tree-dump-times "__var_1" 3 "original" } } +! { dg-final { scan-tree-dump-times "__var_1" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/repeat_4.f90 b/gcc/testsuite/gfortran.dg/repeat_4.f90 index e5b5acc60ce..99e7aee4670 100644 --- a/gcc/testsuite/gfortran.dg/repeat_4.f90 +++ b/gcc/testsuite/gfortran.dg/repeat_4.f90 @@ -2,6 +2,7 @@ ! ! { dg-do compile } program test + use iso_c_binding, only: k => c_size_t implicit none character(len=0), parameter :: s0 = "" character(len=1), parameter :: s1 = "a" @@ -21,18 +22,18 @@ program test print *, repeat(t2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } ! Check for too large NCOPIES argument and limit cases - print *, repeat(t0, huge(0)) - print *, repeat(t1, huge(0)) - print *, repeat(t2, huge(0)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } - print *, repeat(s2, huge(0)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(t0, huge(0_k)) + print *, repeat(t1, huge(0_k)) + print *, repeat(t2, huge(0_k)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0_k)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } - print *, repeat(t0, huge(0)/2) - print *, repeat(t1, huge(0)/2) - print *, repeat(t2, huge(0)/2) + print *, repeat(t0, huge(0_k)/2) + print *, repeat(t1, huge(0_k)/2) + print *, repeat(t2, huge(0_k)/2) - print *, repeat(t0, huge(0)/2+1) - print *, repeat(t1, huge(0)/2+1) - print *, repeat(t2, huge(0)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } - print *, repeat(s2, huge(0)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(t0, huge(0_k)/2+1) + print *, repeat(t1, huge(0_k)/2+1) + print *, repeat(t2, huge(0_k)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0_k)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } end program test diff --git a/gcc/testsuite/gfortran.dg/repeat_7.f90 b/gcc/testsuite/gfortran.dg/repeat_7.f90 new file mode 100644 index 00000000000..82f8dbf4dea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/repeat_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 66310 +! Make sure there is a limit to how large arrays we try to handle at +! compile time. +program p + character, parameter :: z = 'z' + print *, repeat(z, huge(1_4)) +end program p diff --git a/gcc/testsuite/gfortran.dg/scan_2.f90 b/gcc/testsuite/gfortran.dg/scan_2.f90 index c58a3a21a7f..5ef02300d9b 100644 --- a/gcc/testsuite/gfortran.dg/scan_2.f90 +++ b/gcc/testsuite/gfortran.dg/scan_2.f90 @@ -30,5 +30,5 @@ program p1 call s1(.TRUE.) end program p1 -! { dg-final { scan-tree-dump-times "iscan = _gfortran_string_scan \\(2," 1 "original" } } -! { dg-final { scan-tree-dump-times "iverify = _gfortran_string_verify \\(2," 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_string_scan \\(2," 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_string_verify \\(2," 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/string_1.f90 b/gcc/testsuite/gfortran.dg/string_1.f90 index 11dc5b7a340..6a6151e20a4 100644 --- a/gcc/testsuite/gfortran.dg/string_1.f90 +++ b/gcc/testsuite/gfortran.dg/string_1.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-require-effective-target ilp32 } ! program main implicit none diff --git a/gcc/testsuite/gfortran.dg/string_1_lp64.f90 b/gcc/testsuite/gfortran.dg/string_1_lp64.f90 new file mode 100644 index 00000000000..a0edbefc53e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/string_1_lp64.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-require-effective-target lp64 } +! { dg-require-effective-target fortran_integer_16 } +program main + implicit none + integer(kind=16), parameter :: l1 = 2_16**64_16 + character (len=2_16**64_16+4_16), parameter :: s = "" ! { dg-error "too large" } + character (len=2_16**64_8+4_16) :: ch ! { dg-error "too large" } + character (len=l1 + 1_16) :: v ! { dg-error "too large" } + character (len=int(huge(0_8),kind=16) + 1_16) :: z ! { dg-error "too large" } + character (len=int(huge(0_8),kind=16) + 0_16) :: w + + print *, len(s) + +end program main diff --git a/gcc/testsuite/gfortran.dg/string_3.f90 b/gcc/testsuite/gfortran.dg/string_3.f90 index 7daf8d31ae6..4a88b06da7c 100644 --- a/gcc/testsuite/gfortran.dg/string_3.f90 +++ b/gcc/testsuite/gfortran.dg/string_3.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-require-effective-target ilp32 } ! subroutine foo(i) implicit none diff --git a/gcc/testsuite/gfortran.dg/string_3_lp64.f90 b/gcc/testsuite/gfortran.dg/string_3_lp64.f90 new file mode 100644 index 00000000000..162561fad00 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/string_3_lp64.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-require-effective-target lp64 } +! { dg-require-effective-target fortran_integer_16 } +subroutine foo(i) + implicit none + integer, intent(in) :: i + character(len=i) :: s + + s = '' + print *, s(1:2_16**64_16+3_16) ! { dg-error "too large" } + print *, s(2_16**64_16+3_16:2_16**64_16+4_16) ! { dg-error "too large" } + print *, len(s(1:2_16**64_16+3_16)) ! { dg-error "too large" } + print *, len(s(2_16**64_16+3_16:2_16**64_16+4_16)) ! { dg-error "too large" } + + print *, s(2_16**64_16+3_16:1) + print *, s(2_16**64_16+4_16:2_16**64_16+3_16) + print *, len(s(2_16**64_16+3_16:1)) + print *, len(s(2_16**64_16+4_16:2_16**64_16+3_16)) + +end subroutine diff --git a/libgfortran/intrinsics/args.c b/libgfortran/intrinsics/args.c index b01b0e8f01c..4c0e5df6341 100644 --- a/libgfortran/intrinsics/args.c +++ b/libgfortran/intrinsics/args.c @@ -37,7 +37,6 @@ void getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len) { int argc; - int arglen; char **argv; get_args (&argc, &argv); @@ -49,7 +48,7 @@ getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len) if ((*pos) + 1 <= argc && *pos >=0 ) { - arglen = strlen (argv[*pos]); + gfc_charlen_type arglen = strlen (argv[*pos]); if (arglen > val_len) arglen = val_len; memcpy (val, argv[*pos], arglen); @@ -119,7 +118,8 @@ get_command_argument_i4 (GFC_INTEGER_4 *number, char *value, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, gfc_charlen_type value_len) { - int argc, arglen = 0, stat_flag = GFC_GC_SUCCESS; + int argc, stat_flag = GFC_GC_SUCCESS; + gfc_charlen_type arglen = 0; char **argv; if (number == NULL ) @@ -195,10 +195,10 @@ void get_command_i4 (char *command, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, gfc_charlen_type command_len) { - int i, argc, arglen, thisarg; + int i, argc, thisarg; int stat_flag = GFC_GC_SUCCESS; - int tot_len = 0; char **argv; + gfc_charlen_type arglen, tot_len = 0; if (command == NULL && length == NULL && status == NULL) return; /* No need to do anything. */ diff --git a/libgfortran/intrinsics/chmod.c b/libgfortran/intrinsics/chmod.c index d08edc7e146..1299159a7f1 100644 --- a/libgfortran/intrinsics/chmod.c +++ b/libgfortran/intrinsics/chmod.c @@ -64,7 +64,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see static int chmod_internal (char *file, char *mode, gfc_charlen_type mode_len) { - int i; bool ugo[3]; bool rwxXstugo[9]; int set_mode, part; @@ -104,7 +103,7 @@ chmod_internal (char *file, char *mode, gfc_charlen_type mode_len) honor_umask = false; #endif - for (i = 0; i < mode_len; i++) + for (gfc_charlen_type i = 0; i < mode_len; i++) { if (!continue_clause) { diff --git a/libgfortran/intrinsics/env.c b/libgfortran/intrinsics/env.c index 165f8372935..a2f9498e27f 100644 --- a/libgfortran/intrinsics/env.c +++ b/libgfortran/intrinsics/env.c @@ -93,7 +93,8 @@ get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length, gfc_charlen_type name_len, gfc_charlen_type value_len) { - int stat = GFC_SUCCESS, res_len = 0; + int stat = GFC_SUCCESS; + gfc_charlen_type res_len = 0; char *name_nt; char *res; diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c index b2b8396dbb2..72f40d4f42a 100644 --- a/libgfortran/intrinsics/extends_type_of.c +++ b/libgfortran/intrinsics/extends_type_of.c @@ -30,7 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see typedef struct vtype { GFC_INTEGER_4 hash; - GFC_INTEGER_4 size; + size_t size; struct vtype *extends; } vtype; diff --git a/libgfortran/intrinsics/gerror.c b/libgfortran/intrinsics/gerror.c index c414ab80daf..fc51aad09a7 100644 --- a/libgfortran/intrinsics/gerror.c +++ b/libgfortran/intrinsics/gerror.c @@ -39,7 +39,7 @@ export_proto_np(PREFIX(gerror)); void PREFIX(gerror) (char * msg, gfc_charlen_type msg_len) { - int p_len; + gfc_charlen_type p_len; char *p; p = gf_strerror (errno, msg, msg_len); diff --git a/libgfortran/intrinsics/getlog.c b/libgfortran/intrinsics/getlog.c index 7b8f04b7064..518e20faec2 100644 --- a/libgfortran/intrinsics/getlog.c +++ b/libgfortran/intrinsics/getlog.c @@ -70,7 +70,6 @@ export_proto_np(PREFIX(getlog)); void PREFIX(getlog) (char * login, gfc_charlen_type login_len) { - int p_len; char *p; memset (login, ' ', login_len); /* Blank the string. */ @@ -107,7 +106,7 @@ PREFIX(getlog) (char * login, gfc_charlen_type login_len) if (p == NULL) goto cleanup; - p_len = strlen (p); + gfc_charlen_type p_len = strlen (p); if (login_len < p_len) p_len = login_len; memcpy (login, p, p_len); diff --git a/libgfortran/intrinsics/hostnm.c b/libgfortran/intrinsics/hostnm.c index 62560e92ecd..53d9aec943c 100644 --- a/libgfortran/intrinsics/hostnm.c +++ b/libgfortran/intrinsics/hostnm.c @@ -88,8 +88,8 @@ w32_gethostname (char *name, size_t len) static int hostnm_0 (char *name, gfc_charlen_type name_len) { - int val, i; char p[HOST_NAME_MAX + 1]; + int val; memset (name, ' ', name_len); @@ -99,8 +99,7 @@ hostnm_0 (char *name, gfc_charlen_type name_len) if (val == 0) { - i = -1; - while (i < name_len && p[++i] != '\0') + for (gfc_charlen_type i = 0; i < name_len && p[i] != '\0'; i++) name[i] = p[i]; } diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c index 350642d3354..bfec683f528 100644 --- a/libgfortran/intrinsics/string_intrinsics_inc.c +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -177,23 +177,25 @@ string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen, gfc_charlen_type string_len_trim (gfc_charlen_type len, const CHARTYPE *s) { - const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long); - gfc_charlen_type i; + if (len <= 0) + return 0; - i = len - 1; + const size_t long_len = sizeof (unsigned long); + + size_t i = len - 1; /* If we've got the standard (KIND=1) character type, we scan the string in long word chunks to speed it up (until a long word is hit that does not consist of ' 's). */ if (sizeof (CHARTYPE) == 1 && i >= long_len) { - int starting; + size_t starting; unsigned long blank_longword; /* Handle the first characters until we're aligned on a long word boundary. Actually, s + i + 1 must be properly aligned, because s + i will be the last byte of a long word read. */ - starting = ((unsigned long) + starting = ( #ifdef __INTPTR_TYPE__ (__INTPTR_TYPE__) #endif @@ -224,14 +226,15 @@ string_len_trim (gfc_charlen_type len, const CHARTYPE *s) break; } } - - /* Now continue for the last characters with naive approach below. */ - assert (i >= 0); } /* Simply look for the first non-blank character. */ - while (i >= 0 && s[i] == ' ') - --i; + while (s[i] == ' ') + { + if (i == 0) + return 0; + --i; + } return i + 1; } @@ -327,12 +330,12 @@ string_scan (gfc_charlen_type slen, const CHARTYPE *str, if (back) { - for (i = slen - 1; i >= 0; i--) + for (i = slen; i != 0; i--) { for (j = 0; j < setlen; j++) { - if (str[i] == set[j]) - return (i + 1); + if (str[i - 1] == set[j]) + return i; } } } diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index c6431686851..4aafcd0cb57 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -93,17 +93,17 @@ export_proto(transfer_logical); extern void transfer_logical_write (st_parameter_dt *, void *, int); export_proto(transfer_logical_write); -extern void transfer_character (st_parameter_dt *, void *, int); +extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type); export_proto(transfer_character); -extern void transfer_character_write (st_parameter_dt *, void *, int); +extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type); export_proto(transfer_character_write); -extern void transfer_character_wide (st_parameter_dt *, void *, int, int); +extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int); export_proto(transfer_character_wide); extern void transfer_character_wide_write (st_parameter_dt *, - void *, int, int); + void *, gfc_charlen_type, int); export_proto(transfer_character_wide_write); extern void transfer_complex (st_parameter_dt *, void *, int); @@ -2331,7 +2331,7 @@ transfer_logical_write (st_parameter_dt *dtp, void *p, int kind) } void -transfer_character (st_parameter_dt *dtp, void *p, int len) +transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len) { static char *empty_string[0]; @@ -2349,13 +2349,13 @@ transfer_character (st_parameter_dt *dtp, void *p, int len) } void -transfer_character_write (st_parameter_dt *dtp, void *p, int len) +transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len) { transfer_character (dtp, p, len); } void -transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind) +transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind) { static char *empty_string[0]; @@ -2373,7 +2373,7 @@ transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind) } void -transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind) +transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind) { transfer_character_wide (dtp, p, len, kind); } @@ -2410,7 +2410,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, return; iotype = (bt) GFC_DESCRIPTOR_TYPE (desc); - size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc); + size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc); rank = GFC_DESCRIPTOR_RANK (desc); for (n = 0; n < rank; n++) diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 0b62ad9cedf..559dba92635 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -432,10 +432,9 @@ is_trim_ok (st_parameter_dt *dtp) if (dtp->common.flags & IOPARM_DT_HAS_FORMAT) { char *p = dtp->format; - off_t i; if (dtp->common.flags & IOPARM_DT_HAS_BLANK) return false; - for (i = 0; i < dtp->format_len; i++) + for (gfc_charlen_type i = 0; i < dtp->format_len; i++) { if (p[i] == '/') return false; if (p[i] == 'b' || p[i] == 'B') diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index bd2fb16bf3b..c04d243dc08 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -2394,7 +2394,7 @@ namelist_write (st_parameter_dt *dtp) write_character (dtp, "&", 1, 1, NODELIM); /* Write namelist name in upper case - f95 std. */ - for (i = 0 ;i < dtp->namelist_name_len ;i++ ) + for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ ) { c = toupper ((int) dtp->namelist_name[i]); write_character (dtp, &c, 1 ,1, NODELIM); diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 6243a359dba..84df19e3c6f 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -255,7 +255,7 @@ typedef GFC_INTEGER_4 GFC_IO_INT; typedef ptrdiff_t index_type; /* The type used for the lengths of character variables. */ -typedef GFC_INTEGER_4 gfc_charlen_type; +typedef size_t gfc_charlen_type; /* Definitions of CHARACTER data types: - CHARACTER(KIND=1) corresponds to the C char type, -- 2.30.2