diff options
46 files changed, 503 insertions, 194 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ec209b2caf7f..996e9710a2e1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,84 @@ +2017-01-03 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/78534 + PR fortran/66310 + * class.c (gfc_find_derived_vtab): Use gfc_size_kind instead of + hardcoded kind. + (find_intrinsic_vtab): Likewise. + * 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. + * 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. + * iresolve.c (gfc_resolve_repeat): Pass string length directly without + temporary, 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. + * resolve.c (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. + * 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 (get_array_ctor_var_strlen): Use + gfc_conv_mpz_to_tree_type. + * trans-const.c (gfc_conv_mpz_to_tree_type): New function. + * trans-const.h (gfc_conv_mpz_to_tree_type): New prototype. + * 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. + (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. + * trans-stmt.c (gfc_trans_label_assign): Build const of + gfc_charlen_type_node. + (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. + 2017-01-02 Janne Blomqvist <jb@gcc.gnu.org> PR fortran/78534 diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index d507e22ce094..6149adaac98a 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'. @@ -2310,13 +2310,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. */ @@ -2676,7 +2676,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 @@ -2687,11 +2687,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/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 36fc4cc09698..65b47de8dd03 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 3c221eb67d5a..754b0132e068 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; } @@ -636,6 +638,32 @@ gfc_extract_int (gfc_expr *expr, int *result) } +/* Same as gfc_extract_int, but use a HWI. */ + +const char * +gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result) +{ + if (expr->expr_type != EXPR_CONSTANT) + return _("Constant expression required at %C"); + + if (expr->ts.type != BT_INTEGER) + return _("Integer expression required at %C"); + + /* 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)) + { + return _("Integer value too large in expression at %C"); + } + + *result = val.to_shwi (); + + return NULL; +} + + /* Recursively copy a list of reference structures. */ gfc_ref * @@ -1655,7 +1683,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; @@ -1824,18 +1852,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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d168138cae95..e1917a82fb36 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2064,6 +2064,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; @@ -2109,7 +2117,7 @@ typedef struct gfc_expr the value. */ struct { - int length; + gfc_charlen_t length; char *string; } representation; @@ -2165,7 +2173,7 @@ typedef struct gfc_expr struct { - int length; + gfc_charlen_t length; gfc_char_t *string; } character; @@ -2759,6 +2767,9 @@ void gfc_done_2 (void); int get_c_kind (const char *, CInteropKind_t *); +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 *); @@ -2850,6 +2861,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; @@ -3081,6 +3093,7 @@ void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *); void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); +const char *gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *); bool is_subref_array (gfc_expr *); bool gfc_is_simply_contiguous (gfc_expr *, bool, bool); bool gfc_check_init_expr (gfc_expr *); @@ -3098,8 +3111,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 9a263171e475..1a36dd7b80d4 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -3810,12 +3810,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__ > 6 +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 5c3ad42990b0..fd2747fb4f83 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2147,7 +2147,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; @@ -2160,8 +2159,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) { diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index ea9d315d7cf6..992a6d967448 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5765,7 +5765,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; @@ -5776,14 +5776,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 a2c199efb56a..7dd0557bb3b8 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" +#include "tree.h" /* Initialize a typespec to unknown. */ @@ -280,3 +281,24 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[]) return ISOCBINDING_INVALID; } + + +/* 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 d738cf4f2ff6..d9c995f43b9f 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1141,7 +1141,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]; @@ -1271,7 +1271,7 @@ parse_string (void) } -/* Parse a small integer. */ +/* Parse an integer. Should fit in a HOST_WIDE_INT. */ static void parse_integer (int c) @@ -1288,8 +1288,6 @@ parse_integer (int c) } atom_int = 10 * atom_int + c - '0'; - if (atom_int > 99999999) - bad_module ("Integer overflow"); } } @@ -1631,11 +1629,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) @@ -1654,11 +1653,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; @@ -1766,7 +1763,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); @@ -1774,6 +1774,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. */ @@ -1783,7 +1795,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 @@ -2680,7 +2692,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); } } @@ -3382,6 +3394,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; @@ -3596,7 +3609,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, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a75d5feb8f60..be630380fba9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8469,7 +8469,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; @@ -8717,11 +8716,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), @@ -11383,7 +11384,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) @@ -11419,7 +11420,7 @@ 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 && mpz_sgn (cl->length->value.integer) < 0) gfc_replace_expr (cl->length, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index a5a50de5cabc..0bf3cfe9e442 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -5190,7 +5190,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; @@ -5210,7 +5210,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 @@ -5246,7 +5246,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); } @@ -5270,11 +5271,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)) { - const char *res = gfc_extract_int (n, &ncop); + const char *res = gfc_extract_hwi (n, &ncop); gcc_assert (res == NULL); } else @@ -5284,11 +5286,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/target-memory.c b/gcc/fortran/target-memory.c index d239cf114e12..34b61dc2e116 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 5d4655352cc7..ddcaf602b561 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 9a755fbf58dc..0642d56164df 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1909,8 +1909,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; diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 128d47d0fa31..cd4a8d7588ba 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 97308676d16a..7863e833929b 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-expr.c b/gcc/fortran/trans-expr.c index b9c134a11d43..da944a897304 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 @@ -1041,7 +1042,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 { @@ -1088,7 +1089,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)); @@ -1227,7 +1228,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))) @@ -1339,7 +1340,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) tmp = fold_build2_loc (input_location, GT_EXPR, boolean_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); @@ -1367,7 +1368,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, boolean_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); } @@ -2195,7 +2196,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) @@ -2267,7 +2268,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* Check lower bound. */ fault = fold_build2_loc (input_location, LT_EXPR, boolean_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, boolean_type_node, nonempty, fault); if (name) @@ -2303,9 +2304,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; @@ -2315,7 +2316,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, @@ -3115,9 +3117,10 @@ 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, + gfc_charlen_type_node, + fold_convert (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); + tmp = build_range_type (gfc_charlen_type_node, gfc_index_zero_node, tmp); if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); @@ -3180,7 +3183,9 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) { len = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (lse.string_length), - lse.string_length, rse.string_length); + lse.string_length, + fold_convert (TREE_TYPE (lse.string_length), + rse.string_length)); } type = build_pointer_type (type); @@ -5872,7 +5877,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp, - build_int_cst (gfc_charlen_type_node, 0)); + build_zero_cst (TREE_TYPE (tmp))); cl.backend_decl = tmp; } @@ -7201,7 +7206,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)); } @@ -7440,7 +7446,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); } @@ -8106,7 +8113,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)); @@ -8235,7 +8242,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, @@ -9490,7 +9497,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, boolean_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), @@ -9507,7 +9516,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)); } } @@ -9689,7 +9699,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, tmp = fold_build2_loc (input_location, GT_EXPR, boolean_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 a13d3fb3e3f8..9bc0525afd27 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7491,10 +7491,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) nonzero_charlen = NULL_TREE; if (arg1->expr->ts.type == BT_CHARACTER) - nonzero_charlen = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, - arg1->expr->ts.u.cl->backend_decl, - integer_zero_node); + nonzero_charlen + = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + arg1->expr->ts.u.cl->backend_decl, + build_zero_cst + (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl))); if (scalar) { /* A pointer to a scalar. */ @@ -7784,11 +7786,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); @@ -7805,7 +7807,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, boolean_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); @@ -7815,17 +7817,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, boolean_type_node, fold_convert (largest, ncopies), fold_convert (largest, max)); tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, - build_int_cst (size_type_node, 0)); + size_zero_node); cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp, boolean_false_node, cond); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -7842,8 +7844,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. */ @@ -7851,7 +7853,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, boolean_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, @@ -7859,25 +7861,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 fbbad46de672..02e2b918291d 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -339,11 +339,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", diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index df61bab83047..c171ab54b47a 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); @@ -2750,7 +2750,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 @@ -2955,7 +2955,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 { @@ -2968,7 +2968,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 { @@ -5640,7 +5640,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 @@ -6036,7 +6036,8 @@ gfc_trans_allocate (gfc_code * code) e.g., a string. */ memsz = fold_build2_loc (input_location, GT_EXPR, boolean_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); @@ -6332,7 +6333,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); @@ -6613,7 +6614,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 a214aae22d80..448faa31f69a 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -118,6 +118,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; @@ -961,9 +964,13 @@ gfc_init_types (void) wi::mask (n, UNSIGNED, TYPE_PRECISION (size_type_node))); - /* ??? 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 9f1b64f48778..ec154ffdb3a4 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; @@ -35,10 +36,9 @@ extern GTY(()) tree gfc_complex_float128_type_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 8155754f8478..560976989b83 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,21 @@ +2017-01-03 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/78534 + PR fortran/66310 + * gfortran.dg/dependency_49.f90: Change scan-tree-dump-times + due to gfc_trans_string_copy change to avoid + -Wstringop-overflow. + * 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. + * gfortran.dg/transfer_intrinsic_1.f90: Change + scan-tree-dump-times due to gfc_trans_string_copy change to + avoid -Wstringop-overflow. + 2017-01-02 Uros Bizjak <ubizjak@gmail.com> PR target/78967 diff --git a/gcc/testsuite/gfortran.dg/dependency_49.f90 b/gcc/testsuite/gfortran.dg/dependency_49.f90 index 73d517e8f765..43ee284169fe 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" 4 "original" } } +! { dg-final { scan-tree-dump-times "__var_1" 3 "original" } } diff --git a/gcc/testsuite/gfortran.dg/repeat_4.f90 b/gcc/testsuite/gfortran.dg/repeat_4.f90 index e5b5acc60ce6..99e7aee4670f 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 000000000000..82f8dbf4deaa --- /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 c58a3a21a7fe..5ef02300d9ba 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 11dc5b7a3401..6a6151e20a4e 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 000000000000..a0edbefc53e4 --- /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 7daf8d31ae66..4a88b06da7cb 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 000000000000..162561fad00b --- /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/gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90 index 5f46cd0bccf3..73a7e7724f5b 100644 --- a/gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90 +++ b/gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90 @@ -14,4 +14,4 @@ subroutine BytesToString(bytes, string) character(len=*) :: string string = transfer(bytes, string) end subroutine -! { dg-final { scan-tree-dump-times "MIN_EXPR" 1 "original" } } +! { dg-final { scan-tree-dump-times "MIN_EXPR" 2 "original" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index f86dd33c7877..b1f6d045b7db 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,28 @@ +2017-01-03 Janne Blomqvist <jb@gcc.gnu.org> + + 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. + 2017-01-01 Jakub Jelinek <jakub@redhat.com> Update copyright years. diff --git a/libgfortran/intrinsics/args.c b/libgfortran/intrinsics/args.c index c07181f31139..ded5a35f4159 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 d08418d773f8..4e917a1c7f4b 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 f8e376e9dfe3..f8e77584c26e 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 8177e0eefebb..8dc9ef85e226 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 34ea1dfb73fe..51432a4d0109 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 a856cd1eee8d..33ad52e470f1 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 2ccb5bdb3713..2395067eae1f 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 f514f4c6a3ee..0da5130b6538 100644 --- a/libgfortran/intrinsics/string_intrinsics_inc.c +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -224,14 +224,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 +328,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 b47f4e07c82c..9724ccbe5045 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); @@ -2272,7 +2272,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]; @@ -2290,13 +2290,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]; @@ -2314,7 +2314,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); } @@ -2351,7 +2351,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 ed3bc3231ec3..2bd40e4cdcff 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -439,10 +439,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 47970d42de19..86836df1b91f 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -2380,7 +2380,6 @@ void namelist_write (st_parameter_dt *dtp) { namelist_info * t1, *t2, *dummy = NULL; - index_type i; index_type dummy_offset = 0; char c; char * dummy_name = NULL; @@ -2402,7 +2401,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 cfe04760fe50..5b74a9dc8aca 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -250,7 +250,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, |