KJ16609/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2026-02-22 03:46:53 -05:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2007-02-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	PR fortran/30720
	* trans-array.c (gfc_trans_create_temp_array): Remove use of the
	function argument. Always generate code for negative extent.
	Simplify said code.
	* trans-array.h (gfc_trans_create_temp_array): Change prototype.
	* trans-expr.c (gfc_conv_function_call): Remove use of last argument
	of gfc_trans_create_temp_array.
	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Likewise.
	* trans-stmt.c (gfc_conv_elemental_dependencies): Likewise.

2007-02-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	PR fortran/30611
	* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Evaluate
	arguments only once. Generate check that NCOPIES argument is not
	negative.

2007-02-16  Thomas Koenig  <Thomas.Koenig@online.de>

	PR libfortran/30389
	* gfortran.h:  Remove gfc_simplify_init_1.
	* arith.h:  Remove third argument from gfc_compare_string.
	* arith.c(gfc_compare_expression):  Remove third argument
	from call to gfc_compare_string.
	(gfc_compare_string):  Remove third argument xcoll_table.
	Remove use of xcoll_table.
	* misc.c(gfc_init_1):  Remove call to gfc_simplify_init_1.
	* simplify.c(ascii_table):  Remove.
	(xascii_table): Likewise.
	(gfc_simplify_achar):  ICE if extract_int fails.  Remove use of
	ascii_table.  Warn if -Wsurprising and value < 0 or > 127.
	(gfc_simplify_char):  ICE if extract_int fails. Error if
	value < 0 or value > 255.
	(gfc_simplify_iachar):  Remove use of xascii_table.
	Char values outside of 0..255 are an ICE.
	(gfc_simplify_lge):  Remove use of xascii_table.
	(gfc_simplify_lgt):  Likewise.
	(gfc_simplify_lle):  Likewise.
	(gfc_simplify_llt):  Likewise.
	(invert_table):  Remove.
	(gfc_simplify_init_1):  Remove.

2007-02-16  Brooks Moses  <brooks.moses@codesourcery.com>

	PR 30381
	PR 30420
	* simplify.c (convert_mpz_to_unsigned): New function.
	(convert_mpz_to_signed): New function, largely based on
	twos_complement().
	(twos_complement): Removed.
	(gfc_simplify_ibclr): Add conversions to and from an
	unsigned representation before bit-twiddling.
	(gfc_simplify_ibset): Same.
	(gfc_simplify_ishftc): Add checks for overly large
	constant arguments, only check the third argument if
	it's present, carry over high bits into	the result as
	appropriate, and perform the final conversion back to
	a signed representation using the correct sign bit.
	(gfc_simplify_not): Removed unnecessary masking.

2007-02-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	PR fortran/30720
	* gfortran.dg/array_function_1.f90: New test.

2007-02-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	PR fortran/30611
	* gcc/testsuite/gfortran.dg/repeat_1.f90: New test.

2007-02-16  Thomas Koenig  <Thomas.Koenig@online.de>

	PR libfortran/30389
	* gfortran.dg/achar_2.f90:  New test.
	* gfortran.dg/achar_3.f90:  New test.

2007-02-16  Brooks Moses  <brooks.moses@codesourcery.com>

	* gfortran.dg/chkbits.f90: Added IBCLR tests; test calls
	for different integer kinds.
	* gfortran.dg/ishft.f90: Renamed to ishft_1.f90...
	* gfortran.dg/ishft_1.f90: ...Renamed from ishft.f90.
	* gfortran.dg/ishft_2.f90: New test.
	* gfortran.dg/ishft_3.f90: New test.

2007-02-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	PR fortran/30611
	* intrinsics/string_intrinsics.c (string_repeat): Don't check
	if ncopies is negative.

From-SVN: r122039
This commit is contained in:
François-Xavier Coudert
2007-02-16 12:19:01 +00:00
parent e971921d1a
commit bbd150fc1e
22 changed files with 2400 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
gcc/fortran/ChangeLog
View File

@@ -1,3 +1,65 @@
2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30720
* trans-array.c (gfc_trans_create_temp_array): Remove use of the
function argument. Always generate code for negative extent.
Simplify said code.
* trans-array.h (gfc_trans_create_temp_array): Change prototype.
* trans-expr.c (gfc_conv_function_call): Remove use of last argument
of gfc_trans_create_temp_array.
* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Likewise.
* trans-stmt.c (gfc_conv_elemental_dependencies): Likewise.
2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30611
* trans-intrinsic.c (gfc_conv_intrinsic_repeat): Evaluate
arguments only once. Generate check that NCOPIES argument is not
negative.
2007-02-16 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/30389
* gfortran.h: Remove gfc_simplify_init_1.
* arith.h: Remove third argument from gfc_compare_string.
* arith.c(gfc_compare_expression): Remove third argument
from call to gfc_compare_string.
(gfc_compare_string): Remove third argument xcoll_table.
Remove use of xcoll_table.
* misc.c(gfc_init_1): Remove call to gfc_simplify_init_1.
* simplify.c(ascii_table): Remove.
(xascii_table): Likewise.
(gfc_simplify_achar): ICE if extract_int fails. Remove use of
ascii_table. Warn if -Wsurprising and value < 0 or > 127.
(gfc_simplify_char): ICE if extract_int fails. Error if
value < 0 or value > 255.
(gfc_simplify_iachar): Remove use of xascii_table.
Char values outside of 0..255 are an ICE.
(gfc_simplify_lge): Remove use of xascii_table.
(gfc_simplify_lgt): Likewise.
(gfc_simplify_lle): Likewise.
(gfc_simplify_llt): Likewise.
(invert_table): Remove.
(gfc_simplify_init_1): Remove.
2007-02-16 Brooks Moses <brooks.moses@codesourcery.com>
PR 30381
PR 30420
* simplify.c (convert_mpz_to_unsigned): New function.
(convert_mpz_to_signed): New function, largely based on
twos_complement().
(twos_complement): Removed.
(gfc_simplify_ibclr): Add conversions to and from an
unsigned representation before bit-twiddling.
(gfc_simplify_ibset): Same.
(gfc_simplify_ishftc): Add checks for overly large
constant arguments, only check the third argument if
it's present, carry over high bits into the result as
appropriate, and perform the final conversion back to
a signed representation using the correct sign bit.
(gfc_simplify_not): Removed unnecessary masking.
2007-02-14 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/30799

14
gcc/fortran/arith.c
View File

@@ -1134,7 +1134,7 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
break;
case BT_CHARACTER:
rc = gfc_compare_string (op1, op2, NULL);
rc = gfc_compare_string (op1, op2);
break;
case BT_LOGICAL:
@@ -1162,11 +1162,11 @@ compare_complex (gfc_expr * op1, gfc_expr * op2)
/* Given two constant strings and the inverse collating sequence, compare the
strings. We return -1 for a < b, 0 for a == b and 1 for a > b. If the
xcoll_table is NULL, we use the processor's default collating sequence. */
strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
We use the processor's default collating sequence. */
int
gfc_compare_string (gfc_expr * a, gfc_expr * b, const int * xcoll_table)
gfc_compare_string (gfc_expr *a, gfc_expr *b)
{
int len, alen, blen, i, ac, bc;
@@ -1182,12 +1182,6 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int * xcoll_table)
ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
if (xcoll_table != NULL)
{
ac = xcoll_table[ac];
bc = xcoll_table[bc];
}
if (ac < bc)
return -1;
if (ac > bc)

2
gcc/fortran/arith.h
View File

@@ -42,7 +42,7 @@ gfc_expr *gfc_constant_result (bt, int, locus *);
arith gfc_range_check (gfc_expr *);
int gfc_compare_expr (gfc_expr *, gfc_expr *);
int gfc_compare_string (gfc_expr *, gfc_expr *, const int *);
int gfc_compare_string (gfc_expr *, gfc_expr *);
/* Constant folding for gfc_expr trees. */
gfc_expr *gfc_uplus (gfc_expr * op);

3
gcc/fortran/gfortran.h
View File

@@ -1962,9 +1962,6 @@ gfc_intrinsic_sym *gfc_find_function (const char *);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
/* simplify.c */
void gfc_simplify_init_1 (void);
/* match.c -- FIXME */
void gfc_free_iterator (gfc_iterator *, int);
void gfc_free_forall_iterator (gfc_forall_iterator *);

1
gcc/fortran/misc.c
View File

@@ -256,7 +256,6 @@ gfc_init_1 (void)
gfc_scanner_init_1 ();
gfc_arith_init_1 ();
gfc_intrinsic_init_1 ();
gfc_simplify_init_1 ();
}

248
gcc/fortran/simplify.c
View File

@@ -64,31 +64,6 @@ gfc_expr gfc_bad_expr;
everything is reasonably straight-forward. The Standard, chapter 13
is the best comment you'll find for this file anyway. */
/* Static table for converting non-ascii character sets to ascii.
The xascii_table[] is the inverse table. */
static int ascii_table[256] = {
'\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
'\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
'\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
'\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
' ', '!', '"', '#', '$', '%', '&', '\'',
'(', ')', '*', '+', ',', '-', '.', '/',
'0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', ':', ';', '<', '=', '>', '?',
'@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
'`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
'x', 'y', 'z', '{', '|', '}', '~', '\?'
};
static int xascii_table[256];
/* Range checks an expression node. If all goes well, returns the
node, otherwise returns &gfc_bad_expr and frees the node. */
@@ -154,20 +129,56 @@ get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
}
/* Checks if X, which is assumed to represent a two's complement
integer of binary width BITSIZE, has the signbit set. If so, makes
X the corresponding negative number. */
/* Converts an mpz_t signed variable into an unsigned one, assuming
two's complement representations and a binary width of bitsize.
The conversion is a no-op unless x is negative; otherwise, it can
be accomplished by masking out the high bits. */
static void
twos_complement (mpz_t x, int bitsize)
convert_mpz_to_unsigned (mpz_t x, int bitsize)
{
mpz_t mask;
if (mpz_sgn (x) < 0)
{
/* Confirm that no bits above the signed range are unset. */
gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
mpz_init_set_ui (mask, 1);
mpz_mul_2exp (mask, mask, bitsize);
mpz_sub_ui (mask, mask, 1);
mpz_and (x, x, mask);
mpz_clear (mask);
}
else
{
/* Confirm that no bits above the signed range are set. */
gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
}
}
/* Converts an mpz_t unsigned variable into a signed one, assuming
two's complement representations and a binary width of bitsize.
If the bitsize-1 bit is set, this is taken as a sign bit and
the number is converted to the corresponding negative number. */
static void
convert_mpz_to_signed (mpz_t x, int bitsize)
{
mpz_t mask;
/* Confirm that no bits above the unsigned range are set. */
gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
if (mpz_tstbit (x, bitsize - 1) == 1)
{
mpz_init_set_ui(mask, 1);
mpz_mul_2exp(mask, mask, bitsize);
mpz_sub_ui(mask, mask, 1);
mpz_init_set_ui (mask, 1);
mpz_mul_2exp (mask, mask, bitsize);
mpz_sub_ui (mask, mask, 1);
/* We negate the number by hand, zeroing the high bits, that is
make it the corresponding positive number, and then have it
@@ -229,24 +240,27 @@ gfc_simplify_abs (gfc_expr * e)
return result;
}
/* We use the processor's collating sequence, because all
sytems that gfortran currently works on are ASCII. */
gfc_expr *
gfc_simplify_achar (gfc_expr * e)
{
gfc_expr *result;
int index;
int c;
const char *ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
/* We cannot assume that the native character set is ASCII in this
function. */
if (gfc_extract_int (e, &index) != NULL || index < 0 || index > 127)
{
gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
"must be between 0 and 127", &e->where);
return &gfc_bad_expr;
}
ch = gfc_extract_int (e, &c);
if (ch != NULL)
gfc_internal_error ("gfc_simplify_achar: %s", ch);
if (gfc_option.warn_surprising && (c < 0 || c > 127))
gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
&e->where);
result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
&e->where);
@@ -254,7 +268,7 @@ gfc_simplify_achar (gfc_expr * e)
result->value.character.string = gfc_getmem (2);
result->value.character.length = 1;
result->value.character.string[0] = ascii_table[index];
result->value.character.string[0] = c;
result->value.character.string[1] = '\0'; /* For debugger */
return result;
}
@@ -677,6 +691,7 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k)
{
gfc_expr *result;
int c, kind;
const char *ch;
kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
if (kind == -1)
@@ -685,11 +700,14 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
if (gfc_extract_int (e, &c) != NULL || c < 0 || c > UCHAR_MAX)
{
gfc_error ("Bad character in CHAR function at %L", &e->where);
return &gfc_bad_expr;
}
ch = gfc_extract_int (e, &c);
if (ch != NULL)
gfc_internal_error ("gfc_simplify_char: %s", ch);
if (c < 0 || c > UCHAR_MAX)
gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
&e->where);
result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
@@ -1213,6 +1231,8 @@ gfc_simplify_huge (gfc_expr * e)
return result;
}
/* We use the processor's collating sequence, because all
sytems that gfortran currently works on are ASCII. */
gfc_expr *
gfc_simplify_iachar (gfc_expr * e)
@@ -1229,7 +1249,11 @@ gfc_simplify_iachar (gfc_expr * e)
return &gfc_bad_expr;
}
index = xascii_table[(int) e->value.character.string[0] & 0xFF];
index = (unsigned char) e->value.character.string[0];
if (gfc_option.warn_surprising && index > 127)
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
result = gfc_int_expr (index);
result->where = e->where;
@@ -1280,7 +1304,14 @@ gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
gfc_integer_kinds[k].bit_size);
mpz_clrbit (result->value.integer, pos);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
return range_check (result, "IBCLR");
}
@@ -1316,9 +1347,8 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
if (pos + len > bitsize)
{
gfc_error
("Sum of second and third arguments of IBITS exceeds bit size "
"at %L", &y->where);
gfc_error ("Sum of second and third arguments of IBITS exceeds "
"bit size at %L", &y->where);
return &gfc_bad_expr;
}
@@ -1380,9 +1410,13 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
gfc_integer_kinds[k].bit_size);
mpz_setbit (result->value.integer, pos);
twos_complement (result->value.integer, gfc_integer_kinds[k].bit_size);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
return range_check (result, "IBSET");
}
@@ -1406,11 +1440,7 @@ gfc_simplify_ichar (gfc_expr * e)
index = (unsigned char) e->value.character.string[0];
if (index < 0 || index > UCHAR_MAX)
{
gfc_error ("Argument of ICHAR at %L out of range of this processor",
&e->where);
return &gfc_bad_expr;
}
gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
result = gfc_int_expr (index);
result->where = e->where;
@@ -1813,7 +1843,7 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
}
}
twos_complement (result->value.integer, isize);
convert_mpz_to_signed (result->value.integer, isize);
gfc_free (bits);
return result;
@@ -1824,7 +1854,7 @@ gfc_expr *
gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
{
gfc_expr *result;
int shift, ashift, isize, delta, k;
int shift, ashift, isize, ssize, delta, k;
int i, *bits;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
@@ -1837,45 +1867,60 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
}
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
isize = gfc_integer_kinds[k].bit_size;
if (sz != NULL)
{
if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
if (sz->expr_type != EXPR_CONSTANT)
return NULL;
if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
{
gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
return &gfc_bad_expr;
}
if (ssize > isize)
{
gfc_error ("Magnitude of third argument of ISHFTC exceeds "
"BIT_SIZE of first argument at %L", &s->where);
return &gfc_bad_expr;
}
}
else
isize = gfc_integer_kinds[k].bit_size;
ssize = isize;
if (shift >= 0)
ashift = shift;
else
ashift = -shift;
if (ashift > isize)
if (ashift > ssize)
{
gfc_error
("Magnitude of second argument of ISHFTC exceeds third argument "
"at %L", &s->where);
if (sz != NULL)
gfc_error ("Magnitude of second argument of ISHFTC exceeds "
"third argument at %L", &s->where);
else
gfc_error ("Magnitude of second argument of ISHFTC exceeds "
"BIT_SIZE of first argument at %L", &s->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
mpz_set (result->value.integer, e->value.integer);
if (shift == 0)
{
mpz_set (result->value.integer, e->value.integer);
return result;
}
return result;
bits = gfc_getmem (isize * sizeof (int));
convert_mpz_to_unsigned (result->value.integer, isize);
for (i = 0; i < isize; i++)
bits = gfc_getmem (ssize * sizeof (int));
for (i = 0; i < ssize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
delta = isize - ashift;
delta = ssize - ashift;
if (shift > 0)
{
@@ -1887,7 +1932,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
mpz_setbit (result->value.integer, i + shift);
}
for (i = delta; i < isize; i++)
for (i = delta; i < ssize; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i - delta);
@@ -1905,7 +1950,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
mpz_setbit (result->value.integer, i + delta);
}
for (i = ashift; i < isize; i++)
for (i = ashift; i < ssize; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + shift);
@@ -1914,7 +1959,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
}
}
twos_complement (result->value.integer, isize);
convert_mpz_to_signed (result->value.integer, isize);
gfc_free (bits);
return result;
@@ -2109,8 +2154,7 @@ gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0,
&a->where);
return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
}
@@ -2121,7 +2165,7 @@ gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0,
return gfc_logical_expr (gfc_compare_string (a, b) > 0,
&a->where);
}
@@ -2133,8 +2177,7 @@ gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0,
&a->where);
return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
}
@@ -2145,8 +2188,7 @@ gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0,
&a->where);
return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
}
@@ -2664,8 +2706,6 @@ gfc_expr *
gfc_simplify_not (gfc_expr * e)
{
gfc_expr *result;
int i;
mpz_t mask;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@@ -2674,21 +2714,6 @@ gfc_simplify_not (gfc_expr * e)
mpz_com (result->value.integer, e->value.integer);
/* Because of how GMP handles numbers, the result must be ANDed with
a mask. For radices <> 2, this will require change. */
i = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
mpz_init (mask);
mpz_add (mask, gfc_integer_kinds[i].huge, gfc_integer_kinds[i].huge);
mpz_add_ui (mask, mask, 1);
mpz_and (result->value.integer, result->value.integer, mask);
twos_complement (result->value.integer, gfc_integer_kinds[i].bit_size);
mpz_clear (mask);
return range_check (result, "NOT");
}
@@ -4255,28 +4280,3 @@ gfc_convert_constant (gfc_expr * e, bt type, int kind)
return result;
}
/****************** Helper functions ***********************/
/* Given a collating table, create the inverse table. */
static void
invert_table (const int *table, int *xtable)
{
int i;
for (i = 0; i < 256; i++)
xtable[i] = 0;
for (i = 0; i < 256; i++)
xtable[table[i]] = i;
}
void
gfc_simplify_init_1 (void)
{
invert_table (ascii_table, xascii_table);
}

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

@@ -575,7 +575,7 @@ tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
gfc_loopinfo * loop, gfc_ss_info * info,
tree eltype, bool dynamic, bool dealloc,
bool callee_alloc, bool function)
bool callee_alloc)
{
tree type;
tree desc;
@@ -584,11 +584,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
tree nelem;
tree cond;
tree or_expr;
tree thencase;
tree elsecase;
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
int n;
int dim;
@@ -670,19 +665,15 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
if (function)
{
/* Check wether the size for this dimension is negative. */
cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
gfc_index_zero_node);
cond = gfc_evaluate_now (cond, pre);
cond = gfc_evaluate_now (cond, pre);
if (n == 0)
or_expr = cond;
else
or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
if (n == 0)
or_expr = cond;
else
or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
}
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
size = gfc_evaluate_now (size, pre);
}
@@ -691,26 +682,12 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
if (size && !callee_alloc)
{
if (function)
{
var = gfc_create_var (TREE_TYPE (size), "size");
gfc_start_block (&thenblock);
gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
thencase = gfc_finish_block (&thenblock);
gfc_start_block (&elseblock);
gfc_add_modify_expr (&elseblock, var, size);
elsecase = gfc_finish_block (&elseblock);
tmp = gfc_evaluate_now (or_expr, pre);
tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
gfc_add_expr_to_block (pre, tmp);
nelem = var;
size = var;
}
else
nelem = size;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3 (COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
}
@@ -1501,7 +1478,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
}
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
type, dynamic, true, false, false);
type, dynamic, true, false);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
@@ -3091,7 +3068,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
loop->temp_ss->data.info.dimen = n;
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
&loop->temp_ss->data.info, tmp, false, true,
false, false);
false);
}
for (n = 0; n < loop->temp_dim; n++)

2
gcc/fortran/trans-array.h
View File

@@ -32,7 +32,7 @@ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
/* Generate code to create a temporary array. */
tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_loopinfo *,
gfc_ss_info *, tree, bool, bool, bool, bool);
gfc_ss_info *, tree, bool, bool, bool);
/* Generate function entry code for allocation of compiler allocated array
variables. */

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

@@ -2284,8 +2284,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
mustn't be deallocated. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
false, !sym->attr.pointer, callee_alloc,
true);
false, !sym->attr.pointer, callee_alloc);
/* Pass the temporary as the first argument. */
tmp = info->descriptor;

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

@@ -2925,10 +2925,12 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
se->loop->to[n] = upper;
/* Build a destination descriptor, using the pointer, source, as the
data field. This is already allocated so set callee_alloc. */
data field. This is already allocated so set callee_alloc.
FIXME callee_alloc is not set! */
tmp = gfc_typenode_for_spec (&expr->ts);
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
info, tmp, false, true, false, false);
info, tmp, false, true, false);
/* Use memcpy to do the transfer. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
@@ -3307,18 +3309,32 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
tree ncopies;
tree var;
tree type;
tree cond;
args = gfc_conv_intrinsic_function_args (se, expr);
len = TREE_VALUE (args);
tmp = gfc_advance_chain (args, 2);
ncopies = TREE_VALUE (tmp);
/* Check that ncopies is not negative. */
ncopies = gfc_evaluate_now (ncopies, &se->pre);
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
build_int_cst (TREE_TYPE (ncopies), 0));
gfc_trans_runtime_check (cond,
"Argument NCOPIES of REPEAT intrinsic is negative",
&se->pre, &expr->where);
/* Compute the destination length. */
len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
/* Create the argument list and generate the function call. */
arglist = NULL_TREE;
arglist = gfc_chainon_list (arglist, var);
arglist = chainon (arglist, args);
arglist = gfc_chainon_list (arglist, TREE_VALUE (args));
arglist = gfc_chainon_list (arglist, TREE_VALUE (TREE_CHAIN (args)));
arglist = gfc_chainon_list (arglist, ncopies);
tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
gfc_add_expr_to_block (&se->pre, tmp);

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

@@ -268,7 +268,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
tmp = gfc_typenode_for_spec (&e->ts);
tmp = gfc_trans_create_temp_array (&se->pre, &se->post,
&tmp_loop, info, tmp,
false, true, false, false);
false, true, false);
gfc_add_modify_expr (&se->pre, size, tmp);
tmp = fold_convert (pvoid_type_node, info->data);
gfc_add_modify_expr (&se->pre, data, tmp);

51
gcc/testsuite/ChangeLog
View File

@@ -1,3 +1,28 @@
2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30720
* gfortran.dg/array_function_1.f90: New test.
2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30611
* gcc/testsuite/gfortran.dg/repeat_1.f90: New test.
2007-02-16 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/30389
* gfortran.dg/achar_2.f90: New test.
* gfortran.dg/achar_3.f90: New test.
2007-02-16 Brooks Moses <brooks.moses@codesourcery.com>
* gfortran.dg/chkbits.f90: Added IBCLR tests; test calls
for different integer kinds.
* gfortran.dg/ishft.f90: Renamed to ishft_1.f90...
* gfortran.dg/ishft_1.f90: ...Renamed from ishft.f90.
* gfortran.dg/ishft_2.f90: New test.
* gfortran.dg/ishft_3.f90: New test.
2007-02-15 Alexandre Oliva <aoliva@redhat.com>
* g++.dg/tree-ssa/sra-1.C: New.
@@ -64,6 +89,32 @@
PR debug/30189
* gcc.dg/pr30189.c: New test.
<<<<<<< .working
=======
2007-02-05 Dwarakanath Rajagopal <dwarak.rajagopal@amd.com>
* gcc.dg/i386-cpuid.h: Test whether SSE4A is supported
for running tests.
* gcc.target/i386/sse4a-extract.c: New test.
* gcc.target/i386/sse4a-insert.c: New test.
* gcc.target/i386/sse4a-montsd.c: New test.
* gcc.target/i386/sse4a-montss.c: New test.
2007-02-05 Richard Guenther <rguenther@suse.de>
* gcc.target/i386/vectorize3.c: New testcase.
2007-02-05 Hans-Peter Nilsson <hp@axis.com>
PR target/30665
* gcc.dg/torture/pr30665-1.c, gcc.dg/torture/pr30665-2.c: New tests.
2007-02-04 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30611
* gfortran.dg/repeat_1.f90: New test.
>>>>>>> .merge-right.r121773
2007-02-04 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/30605

2026
gcc/testsuite/gfortran.dg/achar_2.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

9
gcc/testsuite/gfortran.dg/achar_3.f90 Normal file
View File

@@ -0,0 +1,9 @@
! { dg-do compile }
! { dg-options "-Wall" }
program main
print *,achar(-3) ! { dg-warning "outside of range" }
print *,achar(200) ! { dg-warning "outside of range" }
print *,char(222+221) ! { dg-error "outside of range" }
print *,char(-44) ! { dg-error "outside of range" }
print *,iachar("ü") ! { dg-warning "outside of range" }
end program main

27
gcc/testsuite/gfortran.dg/array_function_1.f90 Normal file
View File

@@ -0,0 +1,27 @@
! { dg-do run }
! PR fortran/30720
program array_function_1
integer :: a(5), b, l, u
l = 4
u = 2
a = (/ 1, 2, 3, 4, 5 /)
b = f(a(l:u) - 2)
if (b /= 0) call abort
b = f(a(4:2) - 2)
if (b /= 0) call abort
b = f(a(u:l) - 2)
if (b /= 3) call abort
b = f(a(2:4) - 2)
if (b /= 3) call abort
contains
integer function f(x)
integer, dimension(:), intent(in) :: x
f = sum(x)
end function
end program

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

@@ -11,16 +11,23 @@ program chkbits
integer(kind=4) i4
integer(kind=8) i8
i1 = ibset(2147483647,bit_size(i4)-1)
i2 = ibset(2147483647,bit_size(i4)-1)
i4 = ibset(2147483647,bit_size(i4)-1)
i8 = ibset(2147483647,bit_size(i4)-1)
i1 = ibset(huge(0_1), bit_size(i1)-1)
i2 = ibset(huge(0_2), bit_size(i2)-1)
i4 = ibset(huge(0_4), bit_size(i4)-1)
i8 = ibset(huge(0_8), bit_size(i8)-1)
if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) call abort
i1 = not(0)
i2 = not(0)
i4 = not(0)
i8 = not(0)
i1 = ibclr(-1_1, bit_size(i1)-1)
i2 = ibclr(-1_2, bit_size(i2)-1)
i4 = ibclr(-1_4, bit_size(i4)-1)
i8 = ibclr(-1_8, bit_size(i8)-1)
if (i1 /= huge(0_1) .or. i2 /= huge(0_2)) call abort
if (i4 /= huge(0_4) .or. i8 /= huge(0_8)) call abort
i1 = not(0_1)
i2 = not(0_2)
i4 = not(0_4)
i8 = not(0_8)
if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) call abort
end program chkbits

0
gcc/testsuite/gfortran.dg/ishft.f90 → gcc/testsuite/gfortran.dg/ishft_1.f90
View File

6
gcc/testsuite/gfortran.dg/ishft_2.f90 Normal file
View File

@@ -0,0 +1,6 @@
! { dg-do run }
program ishft_2
if ( ishftc(3, 2, 3) /= 5 ) call abort()
if ( ishftc(256+3, 2, 3) /= 256+5 ) call abort()
if ( ishftc(1_4, 31)+1 /= -huge(1_4) ) call abort()
end program

11
gcc/testsuite/gfortran.dg/ishft_3.f90 Normal file
View File

@@ -0,0 +1,11 @@
! { dg-do compile }
program ishft_3
integer i, j
write(*,*) ishftc( 3, 2, 3 )
write(*,*) ishftc( 3, 2, i )
write(*,*) ishftc( 3, i, j )
write(*,*) ishftc( 3, 128 ) ! { dg-error "exceeds BIT_SIZE of first" }
write(*,*) ishftc( 3, 0, 128 ) ! { dg-error "exceeds BIT_SIZE of first" }
write(*,*) ishftc( 3, 0, 0 ) ! { dg-error "Invalid third argument" }
write(*,*) ishftc( 3, 3, 2 ) ! { dg-error "exceeds third argument" }
end program

20
gcc/testsuite/gfortran.dg/repeat_1.f90 Normal file
View File

@@ -0,0 +1,20 @@
! { dg-do run }
! { dg-shouldfail "negative NCOPIES argument to REPEAT intrinsic" }
character(len=80) :: str
integer :: i
i = -1
write(str,"(a)") repeat ("a", f())
if (trim(str) /= "aaaa") call abort
write(str,"(a)") repeat ("a", i)
contains
integer function f()
integer :: x = 5
save x
x = x - 1
f = x
end function f
end
! { dg-output "Fortran runtime error: Argument NCOPIES of REPEAT intrinsic is negative .* line 6)"

6
libgfortran/ChangeLog
View File

@@ -1,3 +1,9 @@
2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/30611
* intrinsics/string_intrinsics.c (string_repeat): Don't check
if ncopies is negative.
2007-02-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/30284

10
libgfortran/intrinsics/string_intrinsics.c
View File

@@ -362,14 +362,8 @@ string_repeat (char * dest, GFC_INTEGER_4 slen,
{
int i;
/* See if ncopies is valid. */
if (ncopies < 0)
{
/* The error is already reported. */
runtime_error ("Augument NCOPIES is negative.");
}
/* Copy characters. */
/* We don't need to check that ncopies is non-negative here, because
the front-end already generates code for that check. */
for (i = 0; i < ncopies; i++)
{
memmove (dest + (i * slen), src, slen);