git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Revert r244448 

From-SVN: r244454
This commit is contained in:
Janne Blomqvist 2017-01-13 21:53:16 +02:00
parent be4aa83d6f
commit c1e9bbcc49
44 changed files with 194 additions and 499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
gcc/fortran/ChangeLog
View File

@ -1,85 +1,3 @@
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> 2017-01-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70697 PR fortran/70697

12
gcc/fortran/class.c
View File

@ -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. * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
Only for unlimited polymorphic classes: Only for unlimited polymorphic classes:
* _len: An integer(C_SIZE_T) to store the string length when the unlimited * _len: An integer(4) to store the string length when the unlimited
polymorphic pointer is used to point to a char array. The '_len' polymorphic pointer is used to point to a char array. The '_len'
component will be zero when no character array is stored in component will be zero when no character array is stored in
'_data'. '_data'.
@ -2310,13 +2310,13 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (!gfc_add_component (vtype, "_size", &c)) if (!gfc_add_component (vtype, "_size", &c))
goto cleanup; goto cleanup;
c->ts.type = BT_INTEGER; c->ts.type = BT_INTEGER;
c->ts.kind = gfc_size_kind; c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE; c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived, /* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on so that the correct initializer can be set later on
(in gfc_conv_structure). */ (in gfc_conv_structure). */
c->ts.u.derived = derived; c->ts.u.derived = derived;
c->initializer = gfc_get_int_expr (gfc_size_kind, c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0); NULL, 0);
/* Add component _extends. */ /* Add component _extends. */
@ -2676,7 +2676,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
if (!gfc_add_component (vtype, "_size", &c)) if (!gfc_add_component (vtype, "_size", &c))
goto cleanup; goto cleanup;
c->ts.type = BT_INTEGER; c->ts.type = BT_INTEGER;
c->ts.kind = gfc_size_kind; c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE; c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of /* Build a minimal expression to make use of
@ -2687,11 +2687,11 @@ find_intrinsic_vtab (gfc_typespec *ts)
e = gfc_get_expr (); e = gfc_get_expr ();
e->ts = *ts; e->ts = *ts;
e->expr_type = EXPR_VARIABLE; e->expr_type = EXPR_VARIABLE;
c->initializer = gfc_get_int_expr (gfc_size_kind, c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, NULL,
ts->type == BT_CHARACTER ts->type == BT_CHARACTER
? ts->kind ? ts->kind
: gfc_element_size (e)); : (int)gfc_element_size (e));
gfc_free_expr (e); gfc_free_expr (e);
/* Add component _extends. */ /* Add component _extends. */

9
gcc/fortran/dump-parse-tree.c
View File

@ -348,10 +348,12 @@ show_constructor (gfc_constructor_base base)
static void static void
show_char_const (const gfc_char_t *c, gfc_charlen_t length) show_char_const (const gfc_char_t *c, int length)
{ {
int i;
fputc ('\'', dumpfile); fputc ('\'', dumpfile);
for (size_t i = 0; i < (size_t) length; i++) for (i = 0; i < length; i++)
{ {
if (c[i] == '\'') if (c[i] == '\'')
fputs ("''", dumpfile); fputs ("''", dumpfile);
@ -463,8 +465,7 @@ show_expr (gfc_expr *p)
break; break;
case BT_HOLLERITH: case BT_HOLLERITH:
fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H", fprintf (dumpfile, "%dH", p->representation.length);
p->representation.length);
c = p->representation.string; c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++) for (i = 0; i < p->representation.length; i++, c++)
{ {

42
gcc/fortran/expr.c
View File

@ -27,7 +27,6 @@ along with GCC; see the file COPYING3. If not see
#include "match.h" #include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */ #include "target-memory.h" /* for gfc_convert_boz */
#include "constructor.h" #include "constructor.h"
#include "tree.h"
/* The following set of functions provide access to gfc_expr* of /* The following set of functions provide access to gfc_expr* of
@ -185,7 +184,7 @@ gfc_get_constant_expr (bt type, int kind, locus *where)
blanked and null-terminated. */ blanked and null-terminated. */
gfc_expr * gfc_expr *
gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) gfc_get_character_expr (int kind, locus *where, const char *src, int len)
{ {
gfc_expr *e; gfc_expr *e;
gfc_char_t *dest; gfc_char_t *dest;
@ -211,14 +210,13 @@ gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t l
/* Get a new expression node that is an integer constant. */ /* Get a new expression node that is an integer constant. */
gfc_expr * gfc_expr *
gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) gfc_get_int_expr (int kind, locus *where, int value)
{ {
gfc_expr *p; gfc_expr *p;
p = gfc_get_constant_expr (BT_INTEGER, kind, p = gfc_get_constant_expr (BT_INTEGER, kind,
where ? where : &gfc_current_locus); where ? where : &gfc_current_locus);
const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); mpz_set_si (p->value.integer, value);
wi::to_mpz (w, p->value.integer, SIGNED);
return p; return p;
} }
@ -638,32 +636,6 @@ 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. */ /* Recursively copy a list of reference structures. */
gfc_ref * gfc_ref *
@ -1683,7 +1655,7 @@ simplify_const_ref (gfc_expr *p)
a substring out of it, update the type-spec's a substring out of it, update the type-spec's
character length according to the first element character length according to the first element
(as all should have the same length). */ (as all should have the same length). */
gfc_charlen_t string_len; int string_len;
if ((c = gfc_constructor_first (p->value.constructor))) if ((c = gfc_constructor_first (p->value.constructor)))
{ {
const gfc_expr* first = c->expr; const gfc_expr* first = c->expr;
@ -1852,18 +1824,18 @@ gfc_simplify_expr (gfc_expr *p, int type)
if (gfc_is_constant_expr (p)) if (gfc_is_constant_expr (p))
{ {
gfc_char_t *s; gfc_char_t *s;
HOST_WIDE_INT start, end; int start, end;
start = 0; start = 0;
if (p->ref && p->ref->u.ss.start) if (p->ref && p->ref->u.ss.start)
{ {
gfc_extract_hwi (p->ref->u.ss.start, &start); gfc_extract_int (p->ref->u.ss.start, &start);
start--; /* Convert from one-based to zero-based. */ start--; /* Convert from one-based to zero-based. */
} }
end = p->value.character.length; end = p->value.character.length;
if (p->ref && p->ref->u.ss.end) if (p->ref && p->ref->u.ss.end)
gfc_extract_hwi (p->ref->u.ss.end, &end); gfc_extract_int (p->ref->u.ss.end, &end);
if (end < start) if (end < start)
end = start; end = start;

21
gcc/fortran/gfortran.h
View File

@ -2064,14 +2064,6 @@ gfc_intrinsic_sym;
typedef splay_tree gfc_constructor_base; 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 typedef struct gfc_expr
{ {
expr_t expr_type; expr_t expr_type;
@ -2117,7 +2109,7 @@ typedef struct gfc_expr
the value. */ the value. */
struct struct
{ {
gfc_charlen_t length; int length;
char *string; char *string;
} }
representation; representation;
@ -2173,7 +2165,7 @@ typedef struct gfc_expr
struct struct
{ {
gfc_charlen_t length; int length;
gfc_char_t *string; gfc_char_t *string;
} }
character; character;
@ -2767,9 +2759,6 @@ void gfc_done_2 (void);
int get_c_kind (const char *, CInteropKind_t *); 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 */ /* options.c */
unsigned int gfc_option_lang_mask (void); unsigned int gfc_option_lang_mask (void);
void gfc_init_options_struct (struct gcc_options *); void gfc_init_options_struct (struct gcc_options *);
@ -2861,7 +2850,6 @@ extern int gfc_atomic_int_kind;
extern int gfc_atomic_logical_kind; extern int gfc_atomic_logical_kind;
extern int gfc_intio_kind; extern int gfc_intio_kind;
extern int gfc_charlen_int_kind; extern int gfc_charlen_int_kind;
extern int gfc_size_kind;
extern int gfc_numeric_storage_size; extern int gfc_numeric_storage_size;
extern int gfc_character_storage_size; extern int gfc_character_storage_size;
@ -3093,7 +3081,6 @@ void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
void gfc_free_actual_arglist (gfc_actual_arglist *); void gfc_free_actual_arglist (gfc_actual_arglist *);
gfc_actual_arglist *gfc_copy_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_int (gfc_expr *, int *);
const char *gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *);
bool is_subref_array (gfc_expr *); bool is_subref_array (gfc_expr *);
bool gfc_is_simply_contiguous (gfc_expr *, bool, bool); bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
bool gfc_check_init_expr (gfc_expr *); bool gfc_check_init_expr (gfc_expr *);
@ -3111,8 +3098,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_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *);
gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *); gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
gfc_expr *gfc_get_constant_expr (bt, int, locus *); gfc_expr *gfc_get_constant_expr (bt, int, locus *);
gfc_expr *gfc_get_character_expr (int, locus *, const char *, gfc_charlen_t len); gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len);
gfc_expr *gfc_get_int_expr (int, locus *, HOST_WIDE_INT); gfc_expr *gfc_get_int_expr (int, locus *, int);
gfc_expr *gfc_get_logical_expr (int, locus *, bool); gfc_expr *gfc_get_logical_expr (int, locus *, bool);
gfc_expr *gfc_get_iokind_expr (locus *, io_kind); gfc_expr *gfc_get_iokind_expr (locus *, io_kind);

42
gcc/fortran/gfortran.texi
View File

@ -3810,42 +3810,12 @@ front ends of GCC, e.g. to GCC's C99 compiler for @code{_Bool}
or GCC's Ada compiler for @code{Boolean}.) or GCC's Ada compiler for @code{Boolean}.)
For arguments of @code{CHARACTER} type, the character length is passed For arguments of @code{CHARACTER} type, the character length is passed
as a hidden argument at the end of the argument list. For as hidden argument. For deferred-length strings, the value is passed
deferred-length strings, the value is passed by reference, otherwise by reference, otherwise by value. The character length has the type
by value. The character length has the C type @code{size_t} (or @code{INTEGER(kind=4)}. Note with C binding, @code{CHARACTER(len=1)}
@code{INTEGER(kind=C_SIZE_T)} in Fortran). Note that this is result variables are returned according to the platform ABI and no
different to older versions of the GNU Fortran compiler, where the hidden length argument is used for dummy arguments; with @code{VALUE},
type of the hidden character length argument was a C @code{int}. In those variables are passed by value.
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 For @code{OPTIONAL} dummy arguments, an absent argument is denoted
by a NULL pointer, except for scalar dummy arguments of type by a NULL pointer, except for scalar dummy arguments of type

5
gcc/fortran/iresolve.c
View File

@ -2147,6 +2147,7 @@ void
gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
gfc_expr *ncopies) gfc_expr *ncopies)
{ {
int len;
gfc_expr *tmp; gfc_expr *tmp;
f->ts.type = BT_CHARACTER; f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind; f->ts.kind = string->ts.kind;
@ -2159,8 +2160,8 @@ gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
tmp = NULL; tmp = NULL;
if (string->expr_type == EXPR_CONSTANT) if (string->expr_type == EXPR_CONSTANT)
{ {
tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL, len = string->value.character.length;
string->value.character.length); tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
} }
else if (string->ts.u.cl && string->ts.u.cl->length) else if (string->ts.u.cl && string->ts.u.cl->length)
{ {

8
gcc/fortran/match.c
View File

@ -5765,7 +5765,7 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
{ {
char name[GFC_MAX_SYMBOL_LEN]; char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp; gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0; int charlen = 0;
if (ts->type == BT_CLASS || ts->type == BT_DERIVED) if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
return NULL; 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 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT) && ts->u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); charlen = mpz_get_si (ts->u.cl->length->value.integer);
if (ts->type != BT_CHARACTER) if (ts->type != BT_CHARACTER)
sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
ts->kind); ts->kind);
else else
snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
gfc_basic_typename (ts->type), charlen, ts->kind); charlen, ts->kind);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL); gfc_add_type (tmp->n.sym, ts, NULL);

22
gcc/fortran/misc.c
View File

@ -22,7 +22,6 @@ along with GCC; see the file COPYING3. If not see
#include "system.h" #include "system.h"
#include "coretypes.h" #include "coretypes.h"
#include "gfortran.h" #include "gfortran.h"
#include "tree.h"
/* Initialize a typespec to unknown. */ /* Initialize a typespec to unknown. */
@ -281,24 +280,3 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
return ISOCBINDING_INVALID; 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);
}

43
gcc/fortran/module.c
View File

@ -1141,7 +1141,7 @@ static atom_type last_atom;
#define MAX_ATOM_SIZE 100 #define MAX_ATOM_SIZE 100
static HOST_WIDE_INT atom_int; static int atom_int;
static char *atom_string, atom_name[MAX_ATOM_SIZE]; static char *atom_string, atom_name[MAX_ATOM_SIZE];
@ -1271,7 +1271,7 @@ parse_string (void)
} }
/* Parse an integer. Should fit in a HOST_WIDE_INT. */ /* Parse a small integer. */
static void static void
parse_integer (int c) parse_integer (int c)
@ -1288,6 +1288,8 @@ parse_integer (int c)
} }
atom_int = 10 * atom_int + c - '0'; atom_int = 10 * atom_int + c - '0';
if (atom_int > 99999999)
bad_module ("Integer overflow");
} }
} }
@ -1629,12 +1631,11 @@ write_char (char out)
static void static void
write_atom (atom_type atom, const void *v) write_atom (atom_type atom, const void *v)
{ {
char buffer[32]; char buffer[20];
/* Workaround -Wmaybe-uninitialized false positive during /* Workaround -Wmaybe-uninitialized false positive during
profiledbootstrap by initializing them. */ profiledbootstrap by initializing them. */
int len; int i = 0, len;
HOST_WIDE_INT i = 0;
const char *p; const char *p;
switch (atom) switch (atom)
@ -1653,9 +1654,11 @@ write_atom (atom_type atom, const void *v)
break; break;
case ATOM_INTEGER: case ATOM_INTEGER:
i = *((const HOST_WIDE_INT *) v); i = *((const int *) v);
if (i < 0)
gfc_internal_error ("write_atom(): Writing negative integer");
snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); sprintf (buffer, "%d", i);
p = buffer; p = buffer;
break; break;
@ -1763,10 +1766,7 @@ static void
mio_integer (int *ip) mio_integer (int *ip)
{ {
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
{ write_atom (ATOM_INTEGER, ip);
HOST_WIDE_INT hwi = *ip;
write_atom (ATOM_INTEGER, &hwi);
}
else else
{ {
require_atom (ATOM_INTEGER); require_atom (ATOM_INTEGER);
@ -1774,18 +1774,6 @@ 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. */ /* Read or write a gfc_intrinsic_op value. */
@ -1795,7 +1783,7 @@ mio_intrinsic_op (gfc_intrinsic_op* op)
/* FIXME: Would be nicer to do this via the operators symbolic name. */ /* FIXME: Would be nicer to do this via the operators symbolic name. */
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
{ {
HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; int converted = (int) *op;
write_atom (ATOM_INTEGER, &converted); write_atom (ATOM_INTEGER, &converted);
} }
else else
@ -2692,7 +2680,7 @@ mio_array_ref (gfc_array_ref *ar)
{ {
for (i = 0; i < ar->dimen; i++) for (i = 0; i < ar->dimen; i++)
{ {
HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; int tmp = (int)ar->dimen_type[i];
write_atom (ATOM_INTEGER, &tmp); write_atom (ATOM_INTEGER, &tmp);
} }
} }
@ -3394,7 +3382,6 @@ fix_mio_expr (gfc_expr *e)
static void static void
mio_expr (gfc_expr **ep) mio_expr (gfc_expr **ep)
{ {
HOST_WIDE_INT hwi;
gfc_expr *e; gfc_expr *e;
atom_type t; atom_type t;
int flag; int flag;
@ -3609,9 +3596,7 @@ mio_expr (gfc_expr **ep)
break; break;
case BT_CHARACTER: case BT_CHARACTER:
hwi = e->value.character.length; mio_integer (&e->value.character.length);
mio_hwi (&hwi);
e->value.character.length = hwi;
e->value.character.string e->value.character.string
= CONST_CAST (gfc_char_t *, = CONST_CAST (gfc_char_t *,
mio_allocated_wide_string (e->value.character.string, mio_allocated_wide_string (e->value.character.string,

18
gcc/fortran/resolve.c
View File

@ -4726,7 +4726,7 @@ gfc_resolve_substring_charlen (gfc_expr *e)
/* Length = (end - start + 1). */ /* Length = (end - start + 1). */
e->ts.u.cl->length = gfc_subtract (end, start); e->ts.u.cl->length = gfc_subtract (end, start);
e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
gfc_get_int_expr (gfc_charlen_int_kind, gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1)); NULL, 1));
/* F2008, 6.4.1: Both the starting point and the ending point shall /* F2008, 6.4.1: Both the starting point and the ending point shall
@ -8469,6 +8469,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
char name[GFC_MAX_SYMBOL_LEN]; char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns; gfc_namespace *ns;
int error = 0; int error = 0;
int charlen = 0;
int rank = 0; int rank = 0;
gfc_ref* ref = NULL; gfc_ref* ref = NULL;
gfc_expr *selector_expr = NULL; gfc_expr *selector_expr = NULL;
@ -8716,13 +8717,11 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_CHARACTER) else if (c->ts.type == BT_CHARACTER)
{ {
HOST_WIDE_INT charlen = 0;
if (c->ts.u.cl && c->ts.u.cl->length if (c->ts.u.cl && c->ts.u.cl->length
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT) && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
snprintf (name, sizeof (name), sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
"__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", charlen, c->ts.kind);
gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
} }
else else
sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
@ -11387,7 +11386,7 @@ resolve_index_expr (gfc_expr *e)
static bool static bool
resolve_charlen (gfc_charlen *cl) resolve_charlen (gfc_charlen *cl)
{ {
int k; int i, k;
bool saved_specification_expr; bool saved_specification_expr;
if (cl->resolved) if (cl->resolved)
@ -11423,10 +11422,9 @@ resolve_charlen (gfc_charlen *cl)
/* F2008, 4.4.3.2: If the character length parameter value evaluates to /* F2008, 4.4.3.2: If the character length parameter value evaluates to
a negative value, the length of character entities declared is zero. */ a negative value, the length of character entities declared is zero. */
if (cl->length && cl->length->expr_type == EXPR_CONSTANT if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
&& mpz_sgn (cl->length->value.integer) < 0)
gfc_replace_expr (cl->length, gfc_replace_expr (cl->length,
gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
/* Check that the character length is not too large. */ /* Check that the character length is not too large. */
k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);

23
gcc/fortran/simplify.c
View File

@ -5198,7 +5198,7 @@ gfc_expr *
gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
{ {
gfc_expr *result; gfc_expr *result;
gfc_charlen_t len; int i, j, len, ncop, nlen;
mpz_t ncopies; mpz_t ncopies;
bool have_length = false; 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 if (e->ts.u.cl && e->ts.u.cl->length
&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT) && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{ {
len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); len = mpz_get_si (e->ts.u.cl->length->value.integer);
have_length = true; have_length = true;
} }
else if (e->expr_type == EXPR_CONSTANT else if (e->expr_type == EXPR_CONSTANT
@ -5254,8 +5254,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
} }
else else
{ {
mpz_init (mlen); mpz_init_set_si (mlen, len);
gfc_mpz_set_hwi (mlen, len);
mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
mpz_clear (mlen); mpz_clear (mlen);
} }
@ -5279,12 +5278,11 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
if (e->expr_type != EXPR_CONSTANT) if (e->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
HOST_WIDE_INT ncop;
if (len || if (len ||
(e->ts.u.cl->length && (e->ts.u.cl->length &&
mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
{ {
const char *res = gfc_extract_hwi (n, &ncop); const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL); gcc_assert (res == NULL);
} }
else else
@ -5294,18 +5292,11 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
len = e->value.character.length; len = e->value.character.length;
gfc_charlen_t nlen = ncop * len; 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); result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
for (size_t i = 0; i < (size_t) ncop; i++) for (i = 0; i < ncop; i++)
for (size_t j = 0; j < (size_t) len; j++) for (j = 0; j < len; j++)
result->value.character.string[j+i*len]= e->value.character.string[j]; result->value.character.string[j+i*len]= e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */ result->value.character.string[nlen] = '\0'; /* For debugger */

19
gcc/fortran/target-memory.c
View File

@ -65,7 +65,7 @@ size_logical (int kind)
static size_t static size_t
size_character (gfc_charlen_t length, int kind) size_character (int length, int kind)
{ {
int i = gfc_validate_kind (BT_CHARACTER, kind, false); int i = gfc_validate_kind (BT_CHARACTER, kind, false);
return length * gfc_character_kinds[i].bit_size / 8; 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->expr_type == EXPR_CONSTANT
&& e->ts.u.cl->length->ts.type == BT_INTEGER) && e->ts.u.cl->length->ts.type == BT_INTEGER)
{ {
HOST_WIDE_INT length; int length;
gfc_extract_hwi (e->ts.u.cl->length, &length); gfc_extract_int (e->ts.u.cl->length, &length);
return size_character (length, e->ts.kind); return size_character (length, e->ts.kind);
} }
else else
@ -217,15 +217,16 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size
int int
gfc_encode_character (int kind, gfc_charlen_t length, const gfc_char_t *string, gfc_encode_character (int kind, int length, const gfc_char_t *string,
unsigned char *buffer, size_t buffer_size) unsigned char *buffer, size_t buffer_size)
{ {
size_t elsize = size_character (1, kind); size_t elsize = size_character (1, kind);
tree type = gfc_get_char_type (kind); tree type = gfc_get_char_type (kind);
int i;
gcc_assert (buffer_size >= size_character (length, kind)); gcc_assert (buffer_size >= size_character (length, kind));
for (size_t i = 0; i < (size_t) length; i++) for (i = 0; i < length; i++)
native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
elsize); elsize);
@ -437,9 +438,11 @@ int
gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
gfc_expr *result) gfc_expr *result)
{ {
int i;
if (result->ts.u.cl && result->ts.u.cl->length) if (result->ts.u.cl && result->ts.u.cl->length)
result->value.character.length = result->value.character.length =
gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer); (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
gcc_assert (buffer_size >= size_character (result->value.character.length, gcc_assert (buffer_size >= size_character (result->value.character.length,
result->ts.kind)); result->ts.kind));
@ -447,7 +450,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
gfc_get_wide_string (result->value.character.length + 1); gfc_get_wide_string (result->value.character.length + 1);
if (result->ts.kind == gfc_default_character_kind) if (result->ts.kind == gfc_default_character_kind)
for (size_t i = 0; i < (size_t) result->value.character.length; i++) for (i = 0; i < result->value.character.length; i++)
result->value.character.string[i] = (gfc_char_t) buffer[i]; result->value.character.string[i] = (gfc_char_t) buffer[i];
else else
{ {
@ -456,7 +459,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
mpz_init (integer); mpz_init (integer);
gcc_assert (bytes <= sizeof (unsigned long)); gcc_assert (bytes <= sizeof (unsigned long));
for (size_t i = 0; i < (size_t) result->value.character.length; i++) for (i = 0; i < result->value.character.length; i++)
{ {
gfc_conv_tree_to_mpz (integer, gfc_conv_tree_to_mpz (integer,
native_interpret_expr (gfc_get_char_type (result->ts.kind), native_interpret_expr (gfc_get_char_type (result->ts.kind),

2
gcc/fortran/target-memory.h
View File

@ -28,7 +28,7 @@ size_t gfc_element_size (gfc_expr *);
size_t gfc_target_expr_size (gfc_expr *); size_t gfc_target_expr_size (gfc_expr *);
/* Write a constant expression in binary form to a target buffer. */ /* Write a constant expression in binary form to a target buffer. */
int gfc_encode_character (int, gfc_charlen_t, const gfc_char_t *, unsigned char *, int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *,
size_t); size_t);
unsigned HOST_WIDE_INT gfc_target_encode_expr (gfc_expr *, unsigned char *, unsigned HOST_WIDE_INT gfc_target_encode_expr (gfc_expr *, unsigned char *,
size_t); size_t);

3
gcc/fortran/trans-array.c
View File

@ -1909,7 +1909,8 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
mpz_init_set_ui (char_len, 1); mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer); mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
*len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
*len = convert (gfc_charlen_type_node, *len);
mpz_clear (char_len); mpz_clear (char_len);
return; return;

12
gcc/fortran/trans-const.c
View File

@ -206,18 +206,6 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind)
return wide_int_to_tree (gfc_get_int_type (kind), val); 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. */ /* Converts a backend tree into a GMP integer. */
void void

1
gcc/fortran/trans-const.h
View File

@ -20,7 +20,6 @@ along with GCC; see the file COPYING3. If not see
/* Converts between INT_CST and GMP integer representations. */ /* Converts between INT_CST and GMP integer representations. */
tree gfc_conv_mpz_to_tree (mpz_t, int); 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); void gfc_conv_tree_to_mpz (mpz_t, tree);
/* Converts between REAL_CST and MPFR floating-point representations. */ /* Converts between REAL_CST and MPFR floating-point representations. */

58
gcc/fortran/trans-expr.c
View File

@ -250,7 +250,7 @@ gfc_class_len_or_zero_get (tree decl)
return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF, return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len, TREE_TYPE (len), decl, len,
NULL_TREE) NULL_TREE)
: build_zero_cst (gfc_charlen_type_node); : integer_zero_node;
} }
@ -884,8 +884,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
{ {
/* Amazingly all data is present to compute the length of a /* Amazingly all data is present to compute the length of a
constant string, but the expression is not yet there. */ constant string, but the expression is not yet there. */
e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
gfc_charlen_int_kind,
&e->where); &e->where);
mpz_set_ui (e->ts.u.cl->length->value.integer, mpz_set_ui (e->ts.u.cl->length->value.integer,
e->value.character.length); e->value.character.length);
@ -903,7 +902,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
else else
tmp = integer_zero_node; tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); gfc_add_modify (&parmse->pre, ctree, tmp);
} }
else if (class_ts.type == BT_CLASS else if (class_ts.type == BT_CLASS
&& class_ts.u.derived->components && class_ts.u.derived->components
@ -1042,7 +1041,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)) if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
slen = build_zero_cst (size_type_node); slen = integer_zero_node;
} }
else else
{ {
@ -1089,7 +1088,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
tmp = slen; tmp = slen;
} }
else else
tmp = build_zero_cst (size_type_node); tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree, gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp)); fold_convert (TREE_TYPE (ctree), tmp));
@ -1228,7 +1227,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
if (from != NULL_TREE && unlimited) if (from != NULL_TREE && unlimited)
from_len = gfc_class_len_or_zero_get (from); from_len = gfc_class_len_or_zero_get (from);
else else
from_len = build_zero_cst (size_type_node); from_len = integer_zero_node;
} }
if (GFC_CLASS_TYPE_P (TREE_TYPE (to))) if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
@ -1340,7 +1339,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
tmp = fold_build2_loc (input_location, GT_EXPR, tmp = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, from_len, boolean_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len))); integer_zero_node);
tmp = fold_build3_loc (input_location, COND_EXPR, tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy); void_type_node, tmp, extcopy, stdcopy);
gfc_add_expr_to_block (&body, tmp); gfc_add_expr_to_block (&body, tmp);
@ -1368,7 +1367,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
extcopy = build_call_vec (fcn_type, fcn, args); extcopy = build_call_vec (fcn_type, fcn, args);
tmp = fold_build2_loc (input_location, GT_EXPR, tmp = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, from_len, boolean_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len))); integer_zero_node);
tmp = fold_build3_loc (input_location, COND_EXPR, tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy); void_type_node, tmp, extcopy, stdcopy);
} }
@ -2200,7 +2199,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); 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 = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
se.expr, build_zero_cst (TREE_TYPE (se.expr))); se.expr, build_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre); gfc_add_block_to_block (pblock, &se.pre);
if (cl->backend_decl) if (cl->backend_decl)
@ -2272,7 +2271,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
/* Check lower bound. */ /* Check lower bound. */
fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
start.expr, start.expr,
build_one_cst (TREE_TYPE (start.expr))); build_int_cst (gfc_charlen_type_node, 1));
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_type_node, nonempty, fault); boolean_type_node, nonempty, fault);
if (name) if (name)
@ -2308,9 +2307,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
if (ref->u.ss.end if (ref->u.ss.end
&& gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
{ {
HOST_WIDE_INT i_len; int i_len;
i_len = gfc_mpz_get_hwi (length) + 1; i_len = mpz_get_si (length) + 1;
if (i_len < 0) if (i_len < 0)
i_len = 0; i_len = 0;
@ -2320,8 +2319,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
else else
{ {
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, end.expr), end.expr, start.expr);
fold_convert (gfc_charlen_type_node, start.expr));
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
build_int_cst (gfc_charlen_type_node, 1), tmp); build_int_cst (gfc_charlen_type_node, 1), tmp);
tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
@ -3121,10 +3119,9 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
{ {
/* Create a temporary variable to hold the result. */ /* Create a temporary variable to hold the result. */
tmp = fold_build2_loc (input_location, MINUS_EXPR, tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_charlen_type_node, gfc_charlen_type_node, len,
fold_convert (gfc_charlen_type_node, len),
build_int_cst (gfc_charlen_type_node, 1)); build_int_cst (gfc_charlen_type_node, 1));
tmp = build_range_type (gfc_charlen_type_node, gfc_index_zero_node, tmp); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
@ -3187,9 +3184,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
{ {
len = fold_build2_loc (input_location, PLUS_EXPR, len = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (lse.string_length), TREE_TYPE (lse.string_length),
lse.string_length, lse.string_length, rse.string_length);
fold_convert (TREE_TYPE (lse.string_length),
rse.string_length));
} }
type = build_pointer_type (type); type = build_pointer_type (type);
@ -5881,7 +5876,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
tmp = fold_build2_loc (input_location, MAX_EXPR, tmp = fold_build2_loc (input_location, MAX_EXPR,
gfc_charlen_type_node, tmp, gfc_charlen_type_node, tmp,
build_zero_cst (TREE_TYPE (tmp))); build_int_cst (gfc_charlen_type_node, 0));
cl.backend_decl = tmp; cl.backend_decl = tmp;
} }
@ -7210,8 +7205,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
/* Update the lhs character length. */ /* Update the lhs character length. */
gfc_add_modify (block, lhs_cl_size, gfc_add_modify (block, lhs_cl_size, size);
fold_convert (TREE_TYPE (lhs_cl_size), size));
} }
@ -7450,8 +7444,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
1, size); 1, size);
gfc_add_modify (&block, dest, gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), tmp)); fold_convert (TREE_TYPE (dest), tmp));
gfc_add_modify (&block, strlen, gfc_add_modify (&block, strlen, se.string_length);
fold_convert (TREE_TYPE (strlen), se.string_length));
tmp = gfc_build_memcpy_call (dest, se.expr, size); tmp = gfc_build_memcpy_call (dest, se.expr, size);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
@ -8118,7 +8111,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
from_len = gfc_evaluate_now (se.expr, block); from_len = gfc_evaluate_now (se.expr, block);
} }
else else
from_len = build_zero_cst (gfc_charlen_type_node); from_len = integer_zero_node;
} }
gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len), gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
from_len)); from_len));
@ -8293,7 +8286,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&block, lse.string_length, rse.string_length); gfc_add_modify (&block, lse.string_length, rse.string_length);
else if (lse.string_length != NULL) else if (lse.string_length != NULL)
gfc_add_modify (&block, lse.string_length, gfc_add_modify (&block, lse.string_length,
build_zero_cst (TREE_TYPE (lse.string_length))); build_int_cst (gfc_charlen_type_node, 0));
} }
gfc_add_modify (&block, lse.expr, gfc_add_modify (&block, lse.expr,
@ -9553,9 +9546,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{ {
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
lse.string_length, lse.string_length, size);
fold_convert (TREE_TYPE (lse.string_length),
size));
/* Jump past the realloc if the lengths are the same. */ /* Jump past the realloc if the lengths are the same. */
tmp = build3_v (COND_EXPR, cond, tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label2), build1_v (GOTO_EXPR, jump_label2),
@ -9572,8 +9563,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
/* Update the lhs character length. */ /* Update the lhs character length. */
size = string_length; size = string_length;
gfc_add_modify (block, lse.string_length, gfc_add_modify (block, lse.string_length, size);
fold_convert (TREE_TYPE (lse.string_length), size));
} }
} }
@ -9755,7 +9745,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
tmp = fold_build2_loc (input_location, GT_EXPR, tmp = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, from_len, boolean_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len))); integer_zero_node);
return fold_build3_loc (input_location, COND_EXPR, return fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, void_type_node, tmp,
extcopy, stdcopy); extcopy, stdcopy);

53
gcc/fortran/trans-intrinsic.c
View File

@ -7497,12 +7497,10 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
nonzero_charlen = NULL_TREE; nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER) if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
= fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
boolean_type_node, arg1->expr->ts.u.cl->backend_decl,
arg1->expr->ts.u.cl->backend_decl, integer_zero_node);
build_zero_cst
(TREE_TYPE (arg1->expr->ts.u.cl->backend_decl)));
if (scalar) if (scalar)
{ {
/* A pointer to a scalar. */ /* A pointer to a scalar. */
@ -7792,11 +7790,11 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* We store in charsize the size of a character. */ /* We store in charsize the size of a character. */
i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8); size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
/* Get the arguments. */ /* Get the arguments. */
gfc_conv_intrinsic_function_args (se, expr, args, 3); gfc_conv_intrinsic_function_args (se, expr, args, 3);
slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre)); slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
src = args[1]; src = args[1];
ncopies = gfc_evaluate_now (args[2], &se->pre); ncopies = gfc_evaluate_now (args[2], &se->pre);
ncopies_type = TREE_TYPE (ncopies); ncopies_type = TREE_TYPE (ncopies);
@ -7813,7 +7811,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
is valid, and nothing happens. */ is valid, and nothing happens. */
n = gfc_create_var (ncopies_type, "ncopies"); n = gfc_create_var (ncopies_type, "ncopies");
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
size_zero_node); build_int_cst (size_type_node, 0));
tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
build_int_cst (ncopies_type, 0), ncopies); build_int_cst (ncopies_type, 0), ncopies);
gfc_add_modify (&se->pre, n, tmp); gfc_add_modify (&se->pre, n, tmp);
@ -7823,17 +7821,17 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
(or equal to) MAX / slen, where MAX is the maximal integer of (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 the gfc_charlen_type_node type. If slen == 0, we need a special
case to avoid the division by zero. */ case to avoid the division by zero. */
max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype, i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
fold_convert (sizetype, max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
TYPE_MAX_VALUE (gfc_charlen_type_node)), max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
slen); fold_convert (size_type_node, max), slen);
largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type) largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
? sizetype : ncopies_type; ? size_type_node : ncopies_type;
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
fold_convert (largest, ncopies), fold_convert (largest, ncopies),
fold_convert (largest, max)); fold_convert (largest, max));
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
size_zero_node); build_int_cst (size_type_node, 0));
cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp, cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
boolean_false_node, cond); boolean_false_node, cond);
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@ -7850,8 +7848,8 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
for (i = 0; i < ncopies; i++) for (i = 0; i < ncopies; i++)
memmove (dest + (i * slen * size), src, slen*size); */ memmove (dest + (i * slen * size), src, slen*size); */
gfc_start_block (&block); gfc_start_block (&block);
count = gfc_create_var (sizetype, "count"); count = gfc_create_var (ncopies_type, "count");
gfc_add_modify (&block, count, size_zero_node); gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
exit_label = gfc_build_label_decl (NULL_TREE); exit_label = gfc_build_label_decl (NULL_TREE);
/* Start the loop body. */ /* Start the loop body. */
@ -7859,7 +7857,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* Exit the loop if count >= ncopies. */ /* Exit the loop if count >= ncopies. */
cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count, cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
fold_convert (sizetype, ncopies)); ncopies);
tmp = build1_v (GOTO_EXPR, exit_label); tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1; TREE_USED (exit_label) = 1;
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
@ -7867,22 +7865,25 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
gfc_add_expr_to_block (&body, tmp); gfc_add_expr_to_block (&body, tmp);
/* Call memmove (dest + (i*slen*size), src, slen*size). */ /* Call memmove (dest + (i*slen*size), src, slen*size). */
tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen, tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
count); fold_convert (gfc_charlen_type_node, slen),
tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp, fold_convert (gfc_charlen_type_node, count));
size); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
tmp, fold_convert (gfc_charlen_type_node, size));
tmp = fold_build_pointer_plus_loc (input_location, tmp = fold_build_pointer_plus_loc (input_location,
fold_convert (pvoid_type_node, dest), tmp); fold_convert (pvoid_type_node, dest), tmp);
tmp = build_call_expr_loc (input_location, tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMMOVE), builtin_decl_explicit (BUILT_IN_MEMMOVE),
3, tmp, src, 3, tmp, src,
fold_build2_loc (input_location, MULT_EXPR, fold_build2_loc (input_location, MULT_EXPR,
size_type_node, slen, size)); size_type_node, slen,
fold_convert (size_type_node,
size)));
gfc_add_expr_to_block (&body, tmp); gfc_add_expr_to_block (&body, tmp);
/* Increment count. */ /* Increment count. */
tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype, tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
count, size_one_node); count, build_int_cst (TREE_TYPE (count), 1));
gfc_add_modify (&body, count, tmp); gfc_add_modify (&body, count, tmp);
/* Build the loop. */ /* Build the loop. */

4
gcc/fortran/trans-io.c
View File

@ -339,11 +339,11 @@ gfc_build_io_library_fndecls (void)
iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_character")), ".wW", get_identifier (PREFIX("transfer_character")), ".wW",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_character_write")), ".wR", get_identifier (PREFIX("transfer_character_write")), ".wR",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_character_wide")), ".wW", get_identifier (PREFIX("transfer_character_wide")), ".wW",

19
gcc/fortran/trans-stmt.c
View File

@ -112,7 +112,7 @@ gfc_trans_label_assign (gfc_code * code)
|| code->label1->defined == ST_LABEL_DO_TARGET) || code->label1->defined == ST_LABEL_DO_TARGET)
{ {
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = build_int_cst (gfc_charlen_type_node, -1); len_tree = integer_minus_one_node;
} }
else else
{ {
@ -125,7 +125,7 @@ gfc_trans_label_assign (gfc_code * code)
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
} }
gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); gfc_add_modify (&se.pre, len, len_tree);
gfc_add_modify (&se.pre, addr, label_tree); gfc_add_modify (&se.pre, addr, label_tree);
return gfc_finish_block (&se.pre); return gfc_finish_block (&se.pre);
@ -2750,7 +2750,7 @@ gfc_trans_character_select (gfc_code *code)
{ {
for (d = cp; d; d = d->right) for (d = cp; d; d = d->right)
{ {
gfc_charlen_t i; int i;
if (d->low) if (d->low)
{ {
gcc_assert (d->low->expr_type == EXPR_CONSTANT gcc_assert (d->low->expr_type == EXPR_CONSTANT
@ -2955,7 +2955,7 @@ gfc_trans_character_select (gfc_code *code)
if (d->low == NULL) if (d->low == NULL)
{ {
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
} }
else else
{ {
@ -2968,7 +2968,7 @@ gfc_trans_character_select (gfc_code *code)
if (d->high == NULL) if (d->high == NULL)
{ {
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
} }
else else
{ {
@ -5640,7 +5640,7 @@ gfc_trans_allocate (gfc_code * code)
{ {
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
temp_var_needed = false; temp_var_needed = false;
expr3_len = build_zero_cst (gfc_charlen_type_node); expr3_len = integer_zero_node;
e3_is = E3_MOLD; e3_is = E3_MOLD;
} }
/* Prevent aliasing, i.e., se.expr may be already a /* Prevent aliasing, i.e., se.expr may be already a
@ -6036,8 +6036,7 @@ gfc_trans_allocate (gfc_code * code)
e.g., a string. */ e.g., a string. */
memsz = fold_build2_loc (input_location, GT_EXPR, memsz = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, expr3_len, boolean_type_node, expr3_len,
build_zero_cst integer_zero_node);
(TREE_TYPE (expr3_len)));
memsz = fold_build3_loc (input_location, COND_EXPR, memsz = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (expr3_esize), TREE_TYPE (expr3_esize),
memsz, tmp, expr3_esize); memsz, tmp, expr3_esize);
@ -6367,7 +6366,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_build_addr_expr (pchar_type_node, gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg))); gfc_build_localized_cstring_const (msg)));
slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
dlen = gfc_get_expr_charlen (code->expr2); dlen = gfc_get_expr_charlen (code->expr2);
slen = fold_build2_loc (input_location, MIN_EXPR, slen = fold_build2_loc (input_location, MIN_EXPR,
TREE_TYPE (slen), dlen, slen); TREE_TYPE (slen), dlen, slen);
@ -6649,7 +6648,7 @@ gfc_trans_deallocate (gfc_code *code)
gfc_add_modify (&errmsg_block, errmsg_str, gfc_add_modify (&errmsg_block, errmsg_str,
gfc_build_addr_expr (pchar_type_node, gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg))); gfc_build_localized_cstring_const (msg)));
slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
dlen = gfc_get_expr_charlen (code->expr2); dlen = gfc_get_expr_charlen (code->expr2);
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,

11
gcc/fortran/trans-types.c
View File

@ -118,9 +118,6 @@ int gfc_intio_kind;
/* The integer kind used to store character lengths. */ /* The integer kind used to store character lengths. */
int gfc_charlen_int_kind; 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. */ /* The size of the numeric storage unit and character storage unit. */
int gfc_numeric_storage_size; int gfc_numeric_storage_size;
int gfc_character_storage_size; int gfc_character_storage_size;
@ -964,13 +961,9 @@ gfc_init_types (void)
wi::mask (n, UNSIGNED, wi::mask (n, UNSIGNED,
TYPE_PRECISION (size_type_node))); TYPE_PRECISION (size_type_node)));
/* Character lengths are of type size_t, except signed. */ /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
gfc_charlen_int_kind = get_int_kind_from_node (size_type_node); gfc_charlen_int_kind = 4;
gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); 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. */ /* Get the type node for the given type and kind. */

4
gcc/fortran/trans-types.h
View File

@ -23,7 +23,6 @@ along with GCC; see the file COPYING3. If not see
#ifndef GFC_BACKEND_H #ifndef GFC_BACKEND_H
#define GFC_BACKEND_H #define GFC_BACKEND_H
extern GTY(()) tree gfc_array_index_type; extern GTY(()) tree gfc_array_index_type;
extern GTY(()) tree gfc_array_range_type; extern GTY(()) tree gfc_array_range_type;
extern GTY(()) tree gfc_character1_type_node; extern GTY(()) tree gfc_character1_type_node;
@ -36,9 +35,10 @@ extern GTY(()) tree gfc_complex_float128_type_node;
/* This is the type used to hold the lengths of character variables. /* This is the type used to hold the lengths of character variables.
It must be the same as the corresponding definition in gfortran.h. */ 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; extern GTY(()) tree gfc_charlen_type_node;
/* The following flags give us information on the correspondence of /* The following flags give us information on the correspondence of
real (and complex) kinds with C floating-point types long double real (and complex) kinds with C floating-point types long double
and __float128. */ and __float128. */

12
gcc/testsuite/ChangeLog
View File

@ -19,18 +19,6 @@
PR c++/71166 PR c++/71166
* g++.dg/cpp0x/constexpr-array18.C: New test. * g++.dg/cpp0x/constexpr-array18.C: New test.
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> 2017-01-13 Jeff Law <law@redhat.com>
* gcc.dg/tree-ssa/ssa-dse-25.c: New test. * gcc.dg/tree-ssa/ssa-dse-25.c: New test.

23
gcc/testsuite/gfortran.dg/repeat_4.f90
View File

@ -2,7 +2,6 @@
! !
! { dg-do compile } ! { dg-do compile }
program test program test
use iso_c_binding, only: k => c_size_t
implicit none implicit none
character(len=0), parameter :: s0 = "" character(len=0), parameter :: s0 = ""
character(len=1), parameter :: s1 = "a" character(len=1), parameter :: s1 = "a"
@ -22,18 +21,18 @@ program test
print *, repeat(t2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } print *, repeat(t2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" }
! Check for too large NCOPIES argument and limit cases ! Check for too large NCOPIES argument and limit cases
print *, repeat(t0, huge(0_k)) print *, repeat(t0, huge(0))
print *, repeat(t1, huge(0_k)) print *, repeat(t1, huge(0))
print *, repeat(t2, huge(0_k)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } print *, repeat(t2, huge(0)) ! { 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(s2, huge(0)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " }
print *, repeat(t0, huge(0_k)/2) print *, repeat(t0, huge(0)/2)
print *, repeat(t1, huge(0_k)/2) print *, repeat(t1, huge(0)/2)
print *, repeat(t2, huge(0_k)/2) print *, repeat(t2, huge(0)/2)
print *, repeat(t0, huge(0_k)/2+1) print *, repeat(t0, huge(0)/2+1)
print *, repeat(t1, huge(0_k)/2+1) print *, repeat(t1, huge(0)/2+1)
print *, repeat(t2, huge(0_k)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } print *, repeat(t2, huge(0)/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 " } print *, repeat(s2, huge(0)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " }
end program test end program test

8
gcc/testsuite/gfortran.dg/repeat_7.f90
View File

@ -1,8 +0,0 @@
! { 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

4
gcc/testsuite/gfortran.dg/scan_2.f90
View File

@ -30,5 +30,5 @@ program p1
call s1(.TRUE.) call s1(.TRUE.)
end program p1 end program p1
! { dg-final { scan-tree-dump-times "_gfortran_string_scan \\(2," 1 "original" } } ! { dg-final { scan-tree-dump-times "iscan = _gfortran_string_scan \\(2," 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_string_verify \\(2," 1 "original" } } ! { dg-final { scan-tree-dump-times "iverify = _gfortran_string_verify \\(2," 1 "original" } }

1
gcc/testsuite/gfortran.dg/string_1.f90
View File

@ -1,5 +1,4 @@
! { dg-do compile } ! { dg-do compile }
! { dg-require-effective-target ilp32 }
! !
program main program main
implicit none implicit none

15
gcc/testsuite/gfortran.dg/string_1_lp64.f90
View File

@ -1,15 +0,0 @@
! { 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

1
gcc/testsuite/gfortran.dg/string_3.f90
View File

@ -1,5 +1,4 @@
! { dg-do compile } ! { dg-do compile }
! { dg-require-effective-target ilp32 }
! !
subroutine foo(i) subroutine foo(i)
implicit none implicit none

20
gcc/testsuite/gfortran.dg/string_3_lp64.f90
View File

@ -1,20 +0,0 @@
! { 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

25
libgfortran/ChangeLog
View File

@ -1,28 +1,3 @@
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> 2017-01-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70696 PR fortran/70696

10
libgfortran/intrinsics/args.c
View File

@ -37,6 +37,7 @@ void
getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len) getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len)
{ {
int argc; int argc;
int arglen;
char **argv; char **argv;
get_args (&argc, &argv); get_args (&argc, &argv);
@ -48,7 +49,7 @@ getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len)
if ((*pos) + 1 <= argc && *pos >=0 ) if ((*pos) + 1 <= argc && *pos >=0 )
{ {
gfc_charlen_type arglen = strlen (argv[*pos]); arglen = strlen (argv[*pos]);
if (arglen > val_len) if (arglen > val_len)
arglen = val_len; arglen = val_len;
memcpy (val, argv[*pos], arglen); memcpy (val, argv[*pos], arglen);
@ -118,8 +119,7 @@ get_command_argument_i4 (GFC_INTEGER_4 *number, char *value,
GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status,
gfc_charlen_type value_len) gfc_charlen_type value_len)
{ {
int argc, stat_flag = GFC_GC_SUCCESS; int argc, arglen = 0, stat_flag = GFC_GC_SUCCESS;
gfc_charlen_type arglen = 0;
char **argv; char **argv;
if (number == NULL ) if (number == NULL )
@ -195,10 +195,10 @@ void
get_command_i4 (char *command, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, get_command_i4 (char *command, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status,
gfc_charlen_type command_len) gfc_charlen_type command_len)
{ {
int i, argc, thisarg; int i, argc, arglen, thisarg;
int stat_flag = GFC_GC_SUCCESS; int stat_flag = GFC_GC_SUCCESS;
int tot_len = 0;
char **argv; char **argv;
gfc_charlen_type arglen, tot_len = 0;
if (command == NULL && length == NULL && status == NULL) if (command == NULL && length == NULL && status == NULL)
return; /* No need to do anything. */ return; /* No need to do anything. */

3
libgfortran/intrinsics/chmod.c
View File

@ -64,6 +64,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
static int static int
chmod_internal (char *file, char *mode, gfc_charlen_type mode_len) chmod_internal (char *file, char *mode, gfc_charlen_type mode_len)
{ {
int i;
bool ugo[3]; bool ugo[3];
bool rwxXstugo[9]; bool rwxXstugo[9];
int set_mode, part; int set_mode, part;
@ -103,7 +104,7 @@ chmod_internal (char *file, char *mode, gfc_charlen_type mode_len)
honor_umask = false; honor_umask = false;
#endif #endif
for (gfc_charlen_type i = 0; i < mode_len; i++) for (i = 0; i < mode_len; i++)
{ {
if (!continue_clause) if (!continue_clause)
{ {

3
libgfortran/intrinsics/env.c
View File

@ -93,8 +93,7 @@ get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length,
gfc_charlen_type name_len, gfc_charlen_type name_len,
gfc_charlen_type value_len) gfc_charlen_type value_len)
{ {
int stat = GFC_SUCCESS; int stat = GFC_SUCCESS, res_len = 0;
gfc_charlen_type res_len = 0;
char *name_nt; char *name_nt;
char *res; char *res;

2
libgfortran/intrinsics/extends_type_of.c
View File

@ -30,7 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
typedef struct vtype typedef struct vtype
{ {
GFC_INTEGER_4 hash; GFC_INTEGER_4 hash;
size_t size; GFC_INTEGER_4 size;
struct vtype *extends; struct vtype *extends;
} }
vtype; vtype;

2
libgfortran/intrinsics/gerror.c
View File

@ -39,7 +39,7 @@ export_proto_np(PREFIX(gerror));
void void
PREFIX(gerror) (char * msg, gfc_charlen_type msg_len) PREFIX(gerror) (char * msg, gfc_charlen_type msg_len)
{ {
gfc_charlen_type p_len; int p_len;
char *p; char *p;
p = gf_strerror (errno, msg, msg_len); p = gf_strerror (errno, msg, msg_len);

3
libgfortran/intrinsics/getlog.c
View File

@ -70,6 +70,7 @@ export_proto_np(PREFIX(getlog));
void void
PREFIX(getlog) (char * login, gfc_charlen_type login_len) PREFIX(getlog) (char * login, gfc_charlen_type login_len)
{ {
int p_len;
char *p; char *p;
memset (login, ' ', login_len); /* Blank the string. */ memset (login, ' ', login_len); /* Blank the string. */
@ -106,7 +107,7 @@ PREFIX(getlog) (char * login, gfc_charlen_type login_len)
if (p == NULL) if (p == NULL)
goto cleanup; goto cleanup;
gfc_charlen_type p_len = strlen (p); p_len = strlen (p);
if (login_len < p_len) if (login_len < p_len)
p_len = login_len; p_len = login_len;
memcpy (login, p, p_len); memcpy (login, p, p_len);

5
libgfortran/intrinsics/hostnm.c
View File

@ -88,8 +88,8 @@ w32_gethostname (char *name, size_t len)
static int static int
hostnm_0 (char *name, gfc_charlen_type name_len) hostnm_0 (char *name, gfc_charlen_type name_len)
{ {
int val, i;
char p[HOST_NAME_MAX + 1]; char p[HOST_NAME_MAX + 1];
int val;
memset (name, ' ', name_len); memset (name, ' ', name_len);
@ -99,7 +99,8 @@ hostnm_0 (char *name, gfc_charlen_type name_len)
if (val == 0) if (val == 0)
{ {
for (gfc_charlen_type i = 0; i < name_len && p[i] != '\0'; i++) i = -1;
while (i < name_len && p[++i] != '\0')
name[i] = p[i]; name[i] = p[i];
} }

17
libgfortran/intrinsics/string_intrinsics_inc.c
View File

@ -224,15 +224,14 @@ string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
break; break;
} }
} }
/* Now continue for the last characters with naive approach below. */
assert (i >= 0);
} }
/* Simply look for the first non-blank character. */ /* Simply look for the first non-blank character. */
while (s[i] == ' ') while (i >= 0 && s[i] == ' ')
{ --i;
if (i == 0)
return 0;
--i;
}
return i + 1; return i + 1;
} }
@ -328,12 +327,12 @@ string_scan (gfc_charlen_type slen, const CHARTYPE *str,
if (back) if (back)
{ {
for (i = slen; i != 0; i--) for (i = slen - 1; i >= 0; i--)
{ {
for (j = 0; j < setlen; j++) for (j = 0; j < setlen; j++)
{ {
if (str[i - 1] == set[j]) if (str[i] == set[j])
return i; return (i + 1);
} }
} }
} }

18
libgfortran/io/transfer.c
View File

@ -93,17 +93,17 @@ export_proto(transfer_logical);
extern void transfer_logical_write (st_parameter_dt *, void *, int); extern void transfer_logical_write (st_parameter_dt *, void *, int);
export_proto(transfer_logical_write); export_proto(transfer_logical_write);
extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type); extern void transfer_character (st_parameter_dt *, void *, int);
export_proto(transfer_character); export_proto(transfer_character);
extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type); extern void transfer_character_write (st_parameter_dt *, void *, int);
export_proto(transfer_character_write); export_proto(transfer_character_write);
extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int); extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
export_proto(transfer_character_wide); export_proto(transfer_character_wide);
extern void transfer_character_wide_write (st_parameter_dt *, extern void transfer_character_wide_write (st_parameter_dt *,
void *, gfc_charlen_type, int); void *, int, int);
export_proto(transfer_character_wide_write); export_proto(transfer_character_wide_write);
extern void transfer_complex (st_parameter_dt *, void *, int); 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 void
transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len) transfer_character (st_parameter_dt *dtp, void *p, int len)
{ {
static char *empty_string[0]; static char *empty_string[0];
@ -2290,13 +2290,13 @@ transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
} }
void void
transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len) transfer_character_write (st_parameter_dt *dtp, void *p, int len)
{ {
transfer_character (dtp, p, len); transfer_character (dtp, p, len);
} }
void void
transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind) transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
{ {
static char *empty_string[0]; static char *empty_string[0];
@ -2314,7 +2314,7 @@ transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, in
} }
void void
transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind) transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
{ {
transfer_character_wide (dtp, p, len, 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; return;
iotype = (bt) GFC_DESCRIPTOR_TYPE (desc); iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc); size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
rank = GFC_DESCRIPTOR_RANK (desc); rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)

3
libgfortran/io/unit.c
View File

@ -439,9 +439,10 @@ is_trim_ok (st_parameter_dt *dtp)
if (dtp->common.flags & IOPARM_DT_HAS_FORMAT) if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
{ {
char *p = dtp->format; char *p = dtp->format;
off_t i;
if (dtp->common.flags & IOPARM_DT_HAS_BLANK) if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
return false; return false;
for (gfc_charlen_type i = 0; i < dtp->format_len; i++) for (i = 0; i < dtp->format_len; i++)
{ {
if (p[i] == '/') return false; if (p[i] == '/') return false;
if (p[i] == 'b' || p[i] == 'B') if (p[i] == 'b' || p[i] == 'B')

3
libgfortran/io/write.c
View File

@ -2380,6 +2380,7 @@ void
namelist_write (st_parameter_dt *dtp) namelist_write (st_parameter_dt *dtp)
{ {
namelist_info * t1, *t2, *dummy = NULL; namelist_info * t1, *t2, *dummy = NULL;
index_type i;
index_type dummy_offset = 0; index_type dummy_offset = 0;
char c; char c;
char * dummy_name = NULL; char * dummy_name = NULL;
@ -2401,7 +2402,7 @@ namelist_write (st_parameter_dt *dtp)
write_character (dtp, "&", 1, 1, NODELIM); write_character (dtp, "&", 1, 1, NODELIM);
/* Write namelist name in upper case - f95 std. */ /* Write namelist name in upper case - f95 std. */
for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ ) for (i = 0 ;i < dtp->namelist_name_len ;i++ )
{ {
c = toupper ((int) dtp->namelist_name[i]); c = toupper ((int) dtp->namelist_name[i]);
write_character (dtp, &c, 1 ,1, NODELIM); write_character (dtp, &c, 1 ,1, NODELIM);

2
libgfortran/libgfortran.h
View File

@ -250,7 +250,7 @@ typedef GFC_INTEGER_4 GFC_IO_INT;
typedef ptrdiff_t index_type; typedef ptrdiff_t index_type;
/* The type used for the lengths of character variables. */ /* The type used for the lengths of character variables. */
typedef size_t gfc_charlen_type; typedef GFC_INTEGER_4 gfc_charlen_type;
/* Definitions of CHARACTER data types: /* Definitions of CHARACTER data types:
- CHARACTER(KIND=1) corresponds to the C char type, - CHARACTER(KIND=1) corresponds to the C char type,