diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 191bfc816a71178eb4e1de04bcf672233a2dfb08..1c7b681282d6845b98b555f9f7831fb0efe6a0e1 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,85 @@
+2017-01-13 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_substring_charlen): Use gfc_charlen_int_kind.
+ (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-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70697
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index d507e22ce0947bd26436c247e6429073b28abc93..6149adaac98aee9e6b2e01331dca66eea040d04b 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 36fc4cc096984219e0d6b2e67204f5caf271bc9a..65b47de8dd031ae712ff46a19903efc500e70308 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 7b95d206c538c46ee35513532e062a94cfc4b7a4..a313328ca4cac1f473dc090f2a4ab4abcce7dd9a 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 f01a290e28f5087a1cc5ddc8fc397c6b50864176..137914aa5d620d595edc277ac46ae21f86ebb503 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 9a263171e475f2838684354621d3c2a1359cac24..1a36dd7b80d473bb5c22df9a033018010a2cf013 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 5c3ad42990b08c05bac1c42123c568268252e8d4..fd2747fb4f83f45dcfe3bc61d5678125097584c8 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 ea9d315d7cf6206b6606b6b4fc9f6d37fc2093b1..992a6d96744833f0cb33caa3f63975270b6faf31 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 a2c199efb56a06bf8e93b2734b3d50f821814066..7dd0557bb3b8bef17ec7c15cfcbb53b9da870e0a 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 b3b09672aca2c593f43a2cbb051bf854cdefd649..ca5301665e155dfd372faac957068eb5b69d49a3 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 a5fe2314372c702c92e0304c5cd57ecd2de3faa3..71880d8da2a1296d4ff4a0d2e8add95282dd7d12 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4726,7 +4726,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
@@ -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),
@@ -11386,7 +11387,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)
@@ -11422,9 +11423,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);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 942b40154471266e4a5d89dea74fa000d43afe31..4ea8163e598066cffee114a9478fe31f6da6aef9 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -5198,7 +5198,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;
@@ -5218,7 +5218,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
@@ -5254,7 +5254,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);
}
@@ -5278,11 +5279,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
@@ -5292,11 +5294,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 d239cf114e12a1a756aec99179c6452d127961db..34b61dc2e11648a0342fa02aeea4bb804771bcb0 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 5d4655352cc785b107c3c1fc63cf191ee89b32c3..ddcaf602b56124548ccbd80367c2d44ef4708024 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 a3aab8e45286ed61c5b1cffadeabcfeb73f4ddf8..7ab2ef6d6f1f226f3eaa7344a8fb9eca1a9ce014 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 128d47d0fa31648501d2b3115e4968b76a4ec3ed..cd4a8d7588ba976c7fb78faaf192be677bd95df9 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 97308676d16aa4b5e2fc28a02c8af1a3d5296d8c..7863e833929bdae9eb4de47af3f5406637994e04 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 01b7dd27dced2dafe11d236c67c380abdf97a3d6..97aa657532225ed3d1bea357cc986705a854f409 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);
}
@@ -2199,7 +2200,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)
@@ -2271,7 +2272,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)
@@ -2307,9 +2308,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;
@@ -2319,7 +2320,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,
@@ -3119,9 +3121,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);
@@ -3184,7 +3187,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);
@@ -5876,7 +5881,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;
}
@@ -7205,7 +7210,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));
}
@@ -7444,7 +7450,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);
}
@@ -8111,7 +8118,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));
@@ -8286,7 +8293,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,
@@ -9546,7 +9553,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),
@@ -9563,7 +9572,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));
}
}
@@ -9745,7 +9755,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 14781ac48146f9aeafedebb8ee299960db6bcfa7..ec26a0d47532164678b98d5d2eba2933bb807428 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7497,10 +7497,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. */
@@ -7790,11 +7792,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);
@@ -7811,7 +7813,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);
@@ -7821,17 +7823,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,
@@ -7848,8 +7850,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. */
@@ -7857,7 +7859,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,
@@ -7865,25 +7867,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 fbbad46de672a4801105b7817f424c1136069342..02e2b918291d3872eb1f4e6b345b3e6506ed42ff 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 856008779babb6c82bcdb480758d39d4a21ae067..6b529748afb8976ab19a83cc40a44713aac0805d 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);
@@ -6366,7 +6367,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);
@@ -6648,7 +6649,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 759b80eecaa044daf2f77d14d96e591c007dbe4d..5da605238778ec586499473fc4dca19debd469fe 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 2974e4513049288cf8242a7b48dcffe7fea1ac9d..00a83e37d9af7918f9e4889df2a68e251f84064a 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 3dd5ae1ffea70219c499b8660a69bf49b9f215f3..dba6a2c0d3b59311c09c5e197ed4866da34a2b8c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2017-01-13 Janne Blomqvist <jb@gcc.gnu.org>
+
+ PR fortran/78534
+ PR fortran/66310
+ * 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.
+
2017-01-13 Jeff Law <law@redhat.com>
* gcc.dg/tree-ssa/ssa-dse-25.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/repeat_4.f90 b/gcc/testsuite/gfortran.dg/repeat_4.f90
index e5b5acc60ce6be47887b9478e9c35190701242a5..99e7aee4670fa36261409153cb58b5c89132c0e5 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 0000000000000000000000000000000000000000..82f8dbf4deaab62625f7aa1c7c2dedb6b3c7128d
--- /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 c58a3a21a7fefa3a93532ee9156ef7784a995445..5ef02300d9bad6dfcfba286a27976f2fa2a10b32 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 11dc5b7a3401150ae062423ef649c1b172a526de..6a6151e20a4ea919040429352827828c57c1d97b 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 0000000000000000000000000000000000000000..a0edbefc53e4cb8df3148b41556f568f588fe782
--- /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 7daf8d31ae665285594f99314ce182f0aaf664fe..4a88b06da7cbbc907e2310c432818f2310365dc1 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 0000000000000000000000000000000000000000..162561fad00b1778e05c63a3b6eaad751f6c0998
--- /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/ChangeLog b/libgfortran/ChangeLog
index 1a687300a78faa70b0b828cc62bdc9168f67dc9a..20b422153b41b363c1789462d68d261639ee443f 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,28 @@
+2017-01-13 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-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70696
diff --git a/libgfortran/intrinsics/args.c b/libgfortran/intrinsics/args.c
index c07181f31139c386018cb093babda888e8a011ad..ded5a35f415901267a584070ed09cde8ebf572e6 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 d08418d773f898960db5540dbdd3da35bd322e3c..4e917a1c7f4b896ebea55fc665fe9d5f340f5cbf 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 f8e376e9dfe32e1e2a26190317fe02e4d6a78bb5..f8e77584c26ed800e4232a04beae3b4e4aebd615 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 8177e0eefebbf666bcb4b0f8ee2d09365d2919e0..8dc9ef85e2266bd57ea595a76899a19ba0d10063 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 34ea1dfb73febb0fa45b7a86c2dd6db874fbc04c..51432a4d010903f8958420157449511fd6997d00 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 a856cd1eee8d86ab7eb04087149720a3466b3005..33ad52e470f1c584ff324e5b27c14cef3ddad2fd 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 2ccb5bdb3713379afce09be7763797440f2ab5fa..2395067eae1fa013e539a94e13c6e069eb1776da 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 f514f4c6a3ee40f45d6ff900a314c7833c18c264..0da5130b6538b43a97e75c5e39c3b7efb52049f7 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 b47f4e07c82cf16481e4dc14cfb55385c84efae0..9724ccbe5045f2ee7361c8964e8c9950c680c3f3 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 ed3bc3231ec350b840534a675a7d12cb0c2ede37..2bd40e4cdcff4d95e90e96c227e3d64b67b4f353 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 47970d42de19d0a7fd015cb4420e562d074afd49..86836df1b91f6cfa5e3933c822dd4e27b64e7d33 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 cfe04760fe500e3ade38664619af2fcc56dd16db..5b74a9dc8aca578654013632b340eb60d31e22da 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,