diff options
51 files changed, 609 insertions, 262 deletions
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 <jb@gcc.gnu.org> + + 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 <tkoenig@gcc.gnu.org> 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 <jb@gcc.gnu.org> + + 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 <jakub@redhat.com> 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, |