OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

arith.c (gfc_convert_integer, [...]): Move to ...

Browse Source 
2019-07-23  Steven G. Kargl  <kargl@gcc.gnu.org>

	* arith.c (gfc_convert_integer, gfc_convert_real, gfc_convert_complex):
	Move to ...
	* primary.c (convert_integer, convert_real, convert_complex): ... here.
	Rename and make static functions.
	(match_integer_constant): Use convert_integer
	(match_real_constant): Use convert_real.
	(match_complex_constant: Use convert_complex.
	* arith.h (gfc_convert_integer, gfc_convert_real, gfc_convert_complex):
	Remove prototypes.
	* array.c (match_array_cons_element): A BOZ cannot be a data 
	statement value.  Jump to a common exit point.
	* check.c (gfc_invalid_boz): New function.  Emit error or warning
	for a BOZ in an invalid context.
	(boz_args_check): Move to top of file to prevent need of forward
	declaration.
	(is_boz_constant): New function.  Check that BOZ expr is constant.
	(gfc_b	z2real): New function. In-place conversion of BOZ literal
	constant to REAL in accordance to F2018.
	(gfc_boz2int): New function. In-place conversion of BOZ literal
 	onstant to INTEGER in accordance to F2018.
	(gfc_check_achar, gfc_check_char, gfc_check_float): Use gfc_invalid_boz.
	Convert BOZ as needed.
	(gfc_check_bge_bgt_ble_blt): Enforce F2018 requirements on BGE, 
	BGT, BLE, and BLT intrinsic functions.
	(gfc_check_cmplx): Re-organize to check kind, if present, first.
	Convert BOZ real and/or imaginary parts as needed in accordance to
	F2018.
	(gfc_check_complex):  Use gfc_invalid_boz.  Convert BOZ as needed.
	(gfc_check_dcmplx, gfc_check_dble ): Convert BOZ as needed.
	(gfc_check_dshift):  Make dshift[lr] conform to F2018 standard.
	 gfc_check_float (gfc_expr *a)
	(gfc_check_iand_ieor_ior):  Make IAND, IEOR, and IOR conform to 
	F2018 standard.
	(gfc_check_int): Conform to F2018 standard.
	(gfc_check_intconv): Deprecate SHORT and LONG aliases for INT2 and
	INT.  Simply return for a BOZ argument. See gfc_simplify_intconv.
	(gfc_check_merge_bits): Make MERGE_BITS conform to Fortran 2018
	standard.
	(gfc_check_real): Remove incorrect comment. Check kind, if present,
	first.  Simply return for a BOZ argument. See gfc_simplify_real.
	(gfc_check_and): Re-do error handling for BOZ arguments.  Remove
	special casing ts.type != BT_INTEGER or BT_LOGICAL.
	* decl.c (match_old_style_init): Check for BOZ in old-style
	initialization.  Issue error or warning depending on
	-fallow-invalid-boz option.  Issue error if variable is not an
	INTEGER or REAL and the value is BOZ.
	* expr.c (gfc_copy_expr): Copy a BT_BOZ gfc_expr.
	(gfc_check_assign): Re-do error handling for a BOZ in an assignment
	statement.  Do in-place conversion of RHS based on LHS type of
	INTEGER or REAL.
	* gfortran.h (gfc_expr): Add a boz component.  Remove is_boz component.
	(gfc_boz2int, gfc_boz2real, gfc_invalid_boz): New prototypes.
	* interface.c (gfc_extend_assign): Guard against replacing an 
	intrinsic involving a BOZ literal constant on RHS.
	* invoke.texi: Doument -fallow-invalid-boz.
	* lang.opt: New option. -fallow-invalid-boz.
	* libgfortran.h (bt): Elevate BOZ to a basic type.
	* misc.c (gfc_basic_typename, gfc_typename): Translate BT_BOZ to BOZ.
	* primary.c (convert_integer, convert_real, convert_complex): to here.
	Rename and make static functions.
	* primary.c(match_boz_constant): Rewrite parsing of a BOZ. Re-do
	error handling.  Deprecate 'X' for hexidecimal and postfix notation.
	Use -fallow-invalid-boz and gfc_invalid_boz to accept deprecated code.
	* resolve.c (resolve_ordinary_assign): Rework a RHS that is a
	BOZ literal constant.  Use gfc_invalid_boz to allow previous
	nonstandard behavior.  Remove range checking of BOZ conversion.
	* simplify.c (convert_boz): Remove function.
	(simplify_cmplx): Remove conversion of BOZ constants, because
	conversion is done in gfc_check_cmplx.
	(gfc_simplify_float): Remove conversion of BOZ constant, because
	conversion is done in gfc_check_float.
	(simplify_intconv): Use gfc_boz2int to convert BOZ to INTEGER.
	Remove range checking for BOZ conversion.
	(gfc_simplify_real): Use k, if present, to determine kind.  Convert
	BOZ to REAL.  Remove range checking for BOZ conversion.
	target-memory.c (gfc_convert_boz): Rewrite to deal with convert of
	a BOZ to a REAL value.

2019-07-23  Steven G. Kargl  <kargl@gcc.gnu.org>

	* gfortran.dg/achar_5.f90: Fix for new BOZ handling.
	* arithmetic_overflow_1.f90: Ditto.
	* gfortran.dg/boz_11.f90: Ditto.
	* gfortran.dg/boz_12.f90: Ditto.
	* gfortran.dg/boz_4.f90: Ditto.
	* gfortran.dg/boz_5.f90: Ditto.
	* gfortran.dg/boz_6.f90: Ditto.
	* gfortran.dg/boz_7.f90: Ditto.
	* gfortran.dg/boz_8.f90: Ditto.
	* gfortran.dg/dec_structure_6.f90: Ditto.
	* gfortran.dg/dec_union_1.f90: Ditto.
	* gfortran.dg/dec_union_2.f90: Ditto.
	* gfortran.dg/dec_union_5.f90: Ditto.
	* gfortran.dg/dshift_3.f90: Ditto.
	* gfortran.dg/gnu_logical_2.f90: Ditto.
	* gfortran.dg/int_conv_1.f90: Ditto.
	* gfortran.dg/ishft_1.f90: Ditto.
	* gfortran.dg/nan_4.f90: Ditto.
	* gfortran.dg/no_range_check_3.f90: Ditto.
	* gfortran.dg/pr16433.f: Ditto.
	* gfortran.dg/pr44491.f90: Ditto.
	* gfortran.dg/pr58027.f90: Ditto.
	* gfortran.dg/pr81509_2.f90: Ditto.
	* gfortran.dg/unf_io_convert_1.f90: Ditto.
	* gfortran.dg/unf_io_convert_2.f90: Ditto.
	* gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90:
	Ditto.
	* gfortran.fortran-torture/execute/intrinsic_mvbits.f90: Ditto.
	* gfortran.fortran-torture/execute/intrinsic_nearest.f90: Ditto.
	* gfortran.fortran-torture/execute/seq_io.f90: Ditto.
	* gfortran.dg/gnu_logical_1.F: Delete test.
	* gfortran.dg/merge_bits_3.f90: New test.
	* gfortran.dg/merge_bits_3.f90: Ditto.
	* gfortran.dg/boz_int.f90: Ditto.
	* gfortran.dg/boz_bge.f90: Ditto.
	* gfortran.dg/boz_complex_1.f90: Ditto.
	* gfortran.dg/boz_complex_2.f90: Ditto.
	* gfortran.dg/boz_complex_3.f90: Ditto.
	* gfortran.dg/boz_dble.f90: Ditto.
	* gfortran.dg/boz_dshift_1.f90: Ditto.
	* gfortran.dg/boz_dshift_2.f90: Ditto.
	* gfortran.dg/boz_float_1.f90: Ditto.
	* gfortran.dg/boz_float_2.f90: Ditto.
	* gfortran.dg/boz_float_3.f90: Ditto.
	* gfortran.dg/boz_iand_1.f90: Ditto.
	* gfortran.dg/boz_iand_2.f90: Ditto.

2019-07-23  Steven G. Kargl  <kargl@gcc.gnu.org>

	* testsuite/libgomp.fortran/reduction4.f90: Update BOZ usage
	* testsuite/libgomp.fortran/reduction5.f90: Ditto.

From-SVN: r273747
This commit is contained in:
Steven G. Kargl 2019-07-23 21:43:21 +00:00
parent 000a002072
commit 8dc63166e0
66 changed files with 1072 additions and 582 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
gcc/fortran/ChangeLog
View File

@ -1,3 +1,83 @@
2019-07-23 Steven G. Kargl <kargl@gcc.gnu.org>
* arith.c (gfc_convert_integer, gfc_convert_real, gfc_convert_complex):
Move to ...
* primary.c (convert_integer, convert_real, convert_complex): ... here.
Rename and make static functions.
(match_integer_constant): Use convert_integer
(match_real_constant): Use convert_real.
(match_complex_constant: Use convert_complex.
* arith.h (gfc_convert_integer, gfc_convert_real, gfc_convert_complex):
Remove prototypes.
* array.c (match_array_cons_element): A BOZ cannot be a data
statement value. Jump to a common exit point.
* check.c (gfc_invalid_boz): New function. Emit error or warning
for a BOZ in an invalid context.
(boz_args_check): Move to top of file to prevent need of forward
declaration.
(is_boz_constant): New function. Check that BOZ expr is constant.
(gfc_boz2real): New function. In-place conversion of BOZ literal
constant to REAL in accordance to F2018.
(gfc_boz2int): New function. In-place conversion of BOZ literal
constant to INTEGER in accordance to F2018.
(gfc_check_achar, gfc_check_char, gfc_check_float): Use gfc_invalid_boz. Convert BOZ
as needed.
(gfc_check_bge_bgt_ble_blt): Enforce F2018 requirements on BGE,
BGT, BLE, and BLT intrinsic functions.
(gfc_check_cmplx): Re-organize to check kind, if present, first.
Convert BOZ real and/or imaginary parts as needed in accordance to
F2018.
(gfc_check_complex): Use gfc_invalid_boz. Convert BOZ as needed.
(gfc_check_dcmplx, gfc_check_dble ): Convert BOZ as needed.
(gfc_check_dshift): Make dshift[lr] conform to F2018 standard.
gfc_check_float (gfc_expr *a)
(gfc_check_iand_ieor_ior): Make IAND, IEOR, and IOR conform to
F2018 standard.
(gfc_check_int): Conform to F2018 standard.
(gfc_check_intconv): Deprecate SHORT and LONG aliases for INT2 and
INT. Simply return for a BOZ argument. See gfc_simplify_intconv.
(gfc_check_merge_bits): Make MERGE_BITS conform to Fortran 2018
standard.
(gfc_check_real): Remove incorrect comment. Check kind, if present,
first. Simply return for a BOZ argument. See gfc_simplify_real.
(gfc_check_and): Re-do error handling for BOZ arguments. Remove
special casing ts.type != BT_INTEGER or BT_LOGICAL.
* decl.c (match_old_style_init): Check for BOZ in old-style
initialization. Issue error or warning depending on
-fallow-invalid-boz option. Issue error if variable is not an
INTEGER or REAL and the value is BOZ.
* expr.c (gfc_copy_expr): Copy a BT_BOZ gfc_expr.
(gfc_check_assign): Re-do error handling for a BOZ in an assignment
statement. Do in-place conversion of RHS based on LHS type of
INTEGER or REAL.
* gfortran.h (gfc_expr): Add a boz component. Remove is_boz component.
(gfc_boz2int, gfc_boz2real, gfc_invalid_boz): New prototypes.
* interface.c (gfc_extend_assign): Guard against replacing an
intrinsic involving a BOZ literal constant on RHS.
* invoke.texi: Doument -fallow-invalid-boz.
* lang.opt: New option. -fallow-invalid-boz.
* libgfortran.h (bt): Elevate BOZ to a basic type.
* misc.c (gfc_basic_typename, gfc_typename): Translate BT_BOZ to BOZ.
* primary.c (convert_integer, convert_real, convert_complex): to here.
Rename and make static functions.
* primary.c(match_boz_constant): Rewrite parsing of a BOZ. Re-do
error handling. Deprecate 'X' for hexidecimal and postfix notation.
Use -fallow-invalid-boz and gfc_invalid_boz to accept deprecated code.
* resolve.c (resolve_ordinary_assign): Rework a RHS that is a
BOZ literal constant. Use gfc_invalid_boz to allow previous
nonstandard behavior. Remove range checking of BOZ conversion.
* simplify.c (convert_boz): Remove function.
(simplify_cmplx): Remove conversion of BOZ constants, because
conversion is done in gfc_check_cmplx.
(gfc_simplify_float): Remove conversion of BOZ constant, because
conversion is done in gfc_check_float.
(simplify_intconv): Use gfc_boz2int to convert BOZ to INTEGER.
Remove range checking for BOZ conversion.
(gfc_simplify_real): Use k, if present, to determine kind. Convert
BOZ to REAL. Remove range checking for BOZ conversion.
target-memory.c (gfc_convert_boz): Rewrite to deal with convert of
a BOZ to a REAL value.
2019-07-21 Thomas König <tkoenig@gcc.gnu.org>
PR libfortran/91030

50
gcc/fortran/arith.c
View File

@ -1892,56 +1892,6 @@ gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
}
/* Convert an integer string to an expression node. */
gfc_expr *
gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
{
gfc_expr *e;
const char *t;
e = gfc_get_constant_expr (BT_INTEGER, kind, where);
/* A leading plus is allowed, but not by mpz_set_str. */
if (buffer[0] == '+')
t = buffer + 1;
else
t = buffer;
mpz_set_str (e->value.integer, t, radix);
return e;
}
/* Convert a real string to an expression node. */
gfc_expr *
gfc_convert_real (const char *buffer, int kind, locus *where)
{
gfc_expr *e;
e = gfc_get_constant_expr (BT_REAL, kind, where);
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
}
/* Convert a pair of real, constant expression nodes to a single
complex expression node. */
gfc_expr *
gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
{
gfc_expr *e;
e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
GFC_MPC_RND_MODE);
return e;
}
/******* Simplification of intrinsic functions with constant arguments *****/

5
gcc/fortran/arith.h
View File

@ -59,11 +59,6 @@ gfc_expr *gfc_ge (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_lt (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
/* Convert strings to literal constants. */
gfc_expr *gfc_convert_integer (const char *, int, int, locus *);
gfc_expr *gfc_convert_real (const char *, int, locus *);
gfc_expr *gfc_convert_complex (gfc_expr *, gfc_expr *, int);
/* Convert a constant of one kind to another kind. */
gfc_expr *gfc_int2int (gfc_expr *, int);
gfc_expr *gfc_int2real (gfc_expr *, int);

18
gcc/fortran/array.c
View File

@ -1110,17 +1110,27 @@ match_array_cons_element (gfc_constructor_base *result)
if (m != MATCH_YES)
return m;
if (expr->ts.type == BT_BOZ)
{
gfc_error ("BOZ literal constant at %L cannot appear in an "
"array constructor", &expr->where);
goto done;
}
if (expr->expr_type == EXPR_FUNCTION
&& expr->ts.type == BT_UNKNOWN
&& strcmp(expr->symtree->name, "null") == 0)
{
{
gfc_error ("NULL() at %C cannot appear in an array constructor");
gfc_free_expr (expr);
return MATCH_ERROR;
}
goto done;
}
gfc_constructor_append_expr (result, expr, &gfc_current_locus);
return MATCH_YES;
done:
gfc_free_expr (expr);
return MATCH_ERROR;
}

492
gcc/fortran/check.c
View File

@ -34,6 +34,225 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
#include "target-memory.h"
/* A BOZ literal constant can appear in a limited number of contexts.
gfc_invalid_boz() is a help function to simplify error/warning generation.
Note, gfortran accepts the nonstandard 'X' for 'Z' the nonstandard
suffix location. If -fallow-invalid-boz is used, then issue a warning;
otherwise issue an error. */
bool
gfc_invalid_boz (const char *msg, locus *loc)
{
if (flag_allow_invalid_boz)
{
gfc_warning (0, msg, loc);
return false;
}
gfc_error (msg, loc);
return true;
}
/* Some precedures take two arguments such that both cannot be BOZ. */
static bool
boz_args_check(gfc_expr *i, gfc_expr *j)
{
if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
{
gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
"literal constants", gfc_current_intrinsic, &i->where,
&j->where);
return false;
}
return true;
}
/* Check that a BOZ is a constant. */
static bool
is_boz_constant (gfc_expr *a)
{
if (a->expr_type != EXPR_CONSTANT)
{
gfc_error ("Invalid use of BOZ literal constant at %L", &a->where);
return false;
}
return true;
}
/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
converts the string into a REAL of the appropriate kind. The treatment
of the sign bit is processor dependent. */
bool
gfc_boz2real (gfc_expr *x, int kind)
{
extern int gfc_max_integer_kind;
gfc_typespec ts;
int len;
char *buf, *str;
if (!is_boz_constant (x))
return false;
/* Determine the length of the required string. */
len = 8 * kind;
if (x->boz.rdx == 16) len /= 4;
if (x->boz.rdx == 8) len = len / 3 + 1;
buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
if (x->boz.len >= len) /* Truncate if necessary. */
{
str = x->boz.str + (x->boz.len - len);
strcpy(buf, str);
}
else /* Copy and pad. */
{
memset (buf, 48, len);
str = buf + (len - x->boz.len);
strcpy (str, x->boz.str);
}
/* Need to adjust leading bits in an octal string. */
if (x->boz.rdx == 8)
{
/* Clear first bit. */
if (kind == 4 || kind == 10 || kind == 16)
{
if (buf[0] == '4')
buf[0] = '0';
else if (buf[0] == '5')
buf[0] = '1';
else if (buf[0] == '6')
buf[0] = '2';
else if (buf[0] == '7')
buf[0] = '3';
}
/* Clear first two bits. */
else
{
if (buf[0] == '4' || buf[0] == '6')
buf[0] = '0';
else if (buf[0] == '5' || buf[0] == '7')
buf[0] = '1';
}
}
/* Reset BOZ string to the truncated or padded version. */
free (x->boz.str);
x->boz.len = len;
x->boz.str = XCNEWVEC (char, len + 1);
strncpy (x->boz.str, buf, len);
/* Convert to widest possible integer. */
gfc_boz2int (x, gfc_max_integer_kind);
ts.type = BT_REAL;
ts.kind = kind;
if (!gfc_convert_boz (x, &ts))
{
gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
return false;
}
return true;
}
/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
converts the string into an INTEGER of the appropriate kind. The
treatment of the sign bit is processor dependent. If the converted
value exceeds the range of the type, then wrap-around semantics are
applied. */
bool
gfc_boz2int (gfc_expr *x, int kind)
{
int i, len;
char *buf, *str;
mpz_t tmp1;
if (!is_boz_constant (x))
return false;
i = gfc_validate_kind (BT_INTEGER, kind, false);
len = gfc_integer_kinds[i].bit_size;
if (x->boz.rdx == 16) len /= 4;
if (x->boz.rdx == 8) len = len / 3 + 1;
buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
if (x->boz.len >= len) /* Truncate if necessary. */
{
str = x->boz.str + (x->boz.len - len);
strcpy(buf, str);
}
else /* Copy and pad. */
{
memset (buf, 48, len);
str = buf + (len - x->boz.len);
strcpy (str, x->boz.str);
}
/* Need to adjust leading bits in an octal string. */
if (x->boz.rdx == 8)
{
/* Clear first bit. */
if (kind == 1 || kind == 4 || kind == 16)
{
if (buf[0] == '4')
buf[0] = '0';
else if (buf[0] == '5')
buf[0] = '1';
else if (buf[0] == '6')
buf[0] = '2';
else if (buf[0] == '7')
buf[0] = '3';
}
/* Clear first two bits. */
else
{
if (buf[0] == '4' || buf[0] == '6')
buf[0] = '0';
else if (buf[0] == '5' || buf[0] == '7')
buf[0] = '1';
}
}
/* Convert as-if unsigned integer. */
mpz_init (tmp1);
mpz_set_str (tmp1, buf, x->boz.rdx);
/* Check for wrap-around. */
if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
{
mpz_t tmp2;
mpz_init (tmp2);
mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
mpz_mod (tmp1, tmp1, tmp2);
mpz_sub (tmp1, tmp1, tmp2);
mpz_clear (tmp2);
}
/* Clear boz info. */
x->boz.rdx = 0;
x->boz.len = 0;
free (x->boz.str);
mpz_init (x->value.integer);
mpz_set (x->value.integer, tmp1);
x->ts.type = BT_INTEGER;
x->ts.kind = kind;
mpz_clear (tmp1);
return true;
}
/* Make sure an expression is a scalar. */
@ -880,8 +1099,19 @@ gfc_check_abs (gfc_expr *a)
bool
gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
if (a->ts.type == BT_BOZ)
{
if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
"ACHAR intrinsic subprogram", &a->where))
return false;
if (!gfc_boz2int (a, gfc_default_integer_kind))
return false;
}
if (!type_check (a, 0, BT_INTEGER))
return false;
if (!kind_check (kind, 1, BT_CHARACTER))
return false;
@ -1471,6 +1701,27 @@ gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
bool
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
{
extern int gfc_max_integer_kind;
/* If i and j are both BOZ, convert to widest INTEGER. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
{
if (!gfc_boz2int (i, gfc_max_integer_kind))
return false;
if (!gfc_boz2int (j, gfc_max_integer_kind))
return false;
}
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
&& !gfc_boz2int (i, j->ts.kind))
return false;
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
&& !gfc_boz2int (j, i->ts.kind))
return false;
if (!type_check (i, 0, BT_INTEGER))
return false;
@ -1503,8 +1754,19 @@ gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
bool
gfc_check_char (gfc_expr *i, gfc_expr *kind)
{
if (i->ts.type == BT_BOZ)
{
if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
"CHAR intrinsic subprogram", &i->where))
return false;
if (!gfc_boz2int (i, gfc_default_integer_kind))
return false;
}
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!kind_check (kind, 1, BT_CHARACTER))
return false;
@ -1590,11 +1852,29 @@ gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
bool
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
int k;
/* Check kind first, because it may be needed in conversion of a BOZ. */
if (kind)
{
if (!kind_check (kind, 2, BT_COMPLEX))
return false;
gfc_extract_int (kind, &k);
}
else
k = gfc_default_complex_kind;
if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k))
return false;
if (!numeric_check (x, 0))
return false;
if (y != NULL)
{
if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k))
return false;
if (!numeric_check (y, 1))
return false;
@ -1615,12 +1895,8 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
&y->where);
return false;
}
}
if (!kind_check (kind, 2, BT_COMPLEX))
return false;
if (!kind && warn_conversion
&& x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
@ -1926,6 +2202,33 @@ gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
bool
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
/* FIXME BOZ. What to do with complex? */
if (!boz_args_check (x, y))
return false;
if (x->ts.type == BT_BOZ)
{
if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
"intrinsic subprogram", &x->where))
return false;
if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind))
return false;
if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind))
return false;
}
if (y->ts.type == BT_BOZ)
{
if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
"intrinsic subprogram", &y->where))
return false;
if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind))
return false;
if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind))
return false;
}
if (!int_or_real_check (x, 0))
return false;
if (!scalar_check (x, 0))
@ -2047,11 +2350,17 @@ bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
bool
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
return false;
if (!numeric_check (x, 0))
return false;
if (y != NULL)
{
if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind))
return false;
if (!numeric_check (y, 1))
return false;
@ -2081,6 +2390,9 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
bool
gfc_check_dble (gfc_expr *x)
{
if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
return false;
if (!numeric_check (x, 0))
return false;
@ -2167,35 +2479,30 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
return true;
}
static bool
boz_args_check(gfc_expr *i, gfc_expr *j)
{
if (i->is_boz && j->is_boz)
{
gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
"literal constants", gfc_current_intrinsic, &i->where,
&j->where);
return false;
}
return true;
}
bool
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
{
/* i and j cannot both be BOZ literal constants. */
if (!boz_args_check (i, j))
return false;
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
&& !gfc_boz2int (i, j->ts.kind))
return false;
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
&& !gfc_boz2int (j, i->ts.kind))
return false;
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!type_check (j, 1, BT_INTEGER))
return false;
if (!boz_args_check (i, j))
return false;
if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1))
if (!same_type_check (i, 0, j, 1))
return false;
if (!type_check (shift, 2, BT_INTEGER))
@ -2204,18 +2511,8 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
if (!nonnegative_check ("SHIFT", shift))
return false;
if (i->is_boz)
{
if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
return false;
i->ts.kind = j->ts.kind;
}
else
{
if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
return false;
j->ts.kind = i->ts.kind;
}
if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
return false;
return true;
}
@ -2367,9 +2664,19 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
return true;
}
bool
gfc_check_float (gfc_expr *a)
{
if (a->ts.type == BT_BOZ)
{
if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the "
"FLOAT intrinsic subprogram", &a->where))
return false;
if (!gfc_boz2int (a, gfc_default_integer_kind))
return false;
}
if (!type_check (a, 0, BT_INTEGER))
return false;
@ -2495,18 +2802,26 @@ gfc_check_i (gfc_expr *i)
bool
gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
{
/* i and j cannot both be BOZ literal constants. */
if (!boz_args_check (i, j))
return false;
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
&& !gfc_boz2int (i, j->ts.kind))
return false;
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
&& !gfc_boz2int (j, i->ts.kind))
return false;
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!type_check (j, 1, BT_INTEGER))
return false;
if (!boz_args_check (i, j))
return false;
if (i->is_boz) i->ts.kind = j->ts.kind;
if (j->is_boz) j->ts.kind = i->ts.kind;
if (i->ts.kind != j->ts.kind)
{
gfc_error ("Arguments of %qs have different kind type parameters "
@ -2658,6 +2973,10 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
bool
gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
/* BOZ is dealt within simplify_int*. */
if (x->ts.type == BT_BOZ)
return true;
if (!numeric_check (x, 0))
return false;
@ -2671,6 +2990,19 @@ gfc_check_int (gfc_expr *x, gfc_expr *kind)
bool
gfc_check_intconv (gfc_expr *x)
{
if (strcmp (gfc_current_intrinsic, "short") == 0
|| strcmp (gfc_current_intrinsic, "long") == 0)
{
gfc_error ("%qs intrinsic subprogram at %L has been deprecated. "
"Use INT intrinsic subprogram.", gfc_current_intrinsic,
&x->where);
return false;
}
/* BOZ is dealt within simplify_int*. */
if (x->ts.type == BT_BOZ)
return true;
if (!numeric_check (x, 0))
return false;
@ -3554,29 +3886,38 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
bool
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
{
/* i and j cannot both be BOZ literal constants. */
if (!boz_args_check (i, j))
return false;
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
&& !gfc_boz2int (i, j->ts.kind))
return false;
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
&& !gfc_boz2int (j, i->ts.kind))
return false;
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!type_check (j, 1, BT_INTEGER))
return false;
if (!boz_args_check (i, j))
if (!same_type_check (i, 0, j, 1))
return false;
if (i->is_boz) i->ts.kind = j->ts.kind;
if (j->is_boz) j->ts.kind = i->ts.kind;
if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
return false;
if (!type_check (mask, 2, BT_INTEGER))
return false;
if (!same_type_check (i, 0, j, 1))
return false;
if (!same_type_check (i, 0, mask, 2))
return false;
if (mask->is_boz) mask->ts.kind = i->ts.kind;
return true;
}
@ -3977,14 +4318,17 @@ gfc_check_rank (gfc_expr *a)
}
/* real, float, sngl. */
bool
gfc_check_real (gfc_expr *a, gfc_expr *kind)
{
if (!numeric_check (a, 0))
if (!kind_check (kind, 1, BT_REAL))
return false;
if (!kind_check (kind, 1, BT_REAL))
/* BOZ is dealt with in gfc_simplify_real. */
if (a->ts.type == BT_BOZ)
return true;
if (!numeric_check (a, 0))
return false;
return true;
@ -6726,30 +7070,22 @@ gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
bool
gfc_check_and (gfc_expr *i, gfc_expr *j)
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
}
/* i and j cannot both be BOZ literal constants. */
if (!boz_args_check (i, j))
return false;
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
}
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
&& !gfc_boz2int (i, j->ts.kind))
return false;
if (i->ts.type != j->ts.type)
{
gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&j->where);
return false;
}
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
&& !gfc_boz2int (j, i->ts.kind))
return false;
if (!same_type_check (i, 0, j, 1, false))
return false;
if (!scalar_check (i, 0))
return false;
@ -6757,12 +7093,6 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
if (!scalar_check (j, 1))
return false;
if (!boz_args_check (i, j))
return false;
if (i->is_boz) i->ts.kind = j->ts.kind;
if (j->is_boz) j->ts.kind = i->ts.kind;
return true;
}

21
gcc/fortran/decl.c
View File

@ -547,7 +547,7 @@ match_old_style_init (const char *name)
match m;
gfc_symtree *st;
gfc_symbol *sym;
gfc_data *newdata;
gfc_data *newdata, *nd;
/* Set up data structure to hold initializers. */
gfc_find_sym_tree (name, NULL, 0, &st);
@ -567,6 +567,25 @@ match_old_style_init (const char *name)
return m;
}
/* Check that a BOZ did not creep into an old-style initialization. */
for (nd = newdata; nd; nd = nd->next)
{
if (nd->value->expr->ts.type == BT_BOZ
&& gfc_invalid_boz ("BOZ at %L cannot appear in an old-style "
"initialization", &nd->value->expr->where))
return MATCH_ERROR;
if (nd->var->expr->ts.type != BT_INTEGER
&& nd->var->expr->ts.type != BT_REAL
&& nd->value->expr->ts.type == BT_BOZ)
{
gfc_error ("Mismatch in variable type and BOZ literal constant "
"at %L in an old-style initialization",
&nd->value->expr->where);
return MATCH_ERROR;
}
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization at %C is not allowed in a PURE procedure");

46
gcc/fortran/expr.c
View File

@ -342,6 +342,13 @@ gfc_copy_expr (gfc_expr *p)
case BT_ASSUMED:
break; /* Already done. */
case BT_BOZ:
q->boz.len = p->boz.len;
q->boz.rdx = p->boz.rdx;
q->boz.str = XCNEWVEC (char, q->boz.len + 1);
strncpy (q->boz.str, p->boz.str, p->boz.len);
break;
case BT_PROCEDURE:
case BT_VOID:
/* Should never be reached. */
@ -3634,45 +3641,30 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
&& !gfc_check_conformance (lvalue, rvalue, "array assignment"))
return false;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
if (rvalue->ts.type == BT_BOZ && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
"initialize non-integer variable %qs",
&rvalue->where, lvalue->symtree->n.sym->name))
return false;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
else if (rvalue->ts.type == BT_BOZ && !lvalue->symtree->n.sym->attr.data
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&rvalue->where))
return false;
/* Handle the case of a BOZ literal on the RHS. */
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
if (rvalue->ts.type == BT_BOZ)
{
int rc;
if (warn_surprising)
gfc_warning (OPT_Wsurprising,
"BOZ literal at %L is bitwise transferred "
"non-integer symbol %qs", &rvalue->where,
lvalue->symtree->n.sym->name);
if (!gfc_convert_boz (rvalue, &lvalue->ts))
return false;
if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
{
if (rc == ARITH_UNDERFLOW)
gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_OVERFLOW)
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_NAN)
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rvalue->where);
return false;
}
/* FIXME BOZ. Need gfc_invalid_boz() here?. */
if (lvalue->ts.type == BT_INTEGER
&& gfc_boz2int (rvalue, lvalue->ts.kind))
return true;
if (lvalue->ts.type == BT_REAL
&& gfc_boz2real (rvalue, lvalue->ts.kind))
return true;
return false;
}
if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)

17
gcc/fortran/gfortran.h
View File

@ -2152,9 +2152,8 @@ typedef struct gfc_expr
is not a variable. */
struct gfc_expr *base_expr;
/* is_boz is true if the integer is regarded as BOZ bit pattern and is_snan
denotes a signalling not-a-number. */
unsigned int is_boz : 1, is_snan : 1;
/* is_snan denotes a signalling not-a-number. */
unsigned int is_snan : 1;
/* Sometimes, when an error has been emitted, it is necessary to prevent
it from recurring. */
@ -2198,6 +2197,14 @@ typedef struct gfc_expr
}
representation;
struct
{
int len; /* Length of BOZ string without terminating NULL. */
int rdx; /* Radix of BOZ. */
char *str; /* BOZ string with NULL terminating character. */
}
boz;
union
{
int logical;
@ -3479,6 +3486,10 @@ bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *);
bool gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
size_t*, size_t*, size_t*);
bool gfc_boz2int (gfc_expr *, int);
bool gfc_boz2real (gfc_expr *, int);
bool gfc_invalid_boz (const char *, locus *);
/* class.c */
void gfc_fix_class_refs (gfc_expr *e);

6
gcc/fortran/interface.c
View File

@ -4274,6 +4274,12 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
lhs = c->expr1;
rhs = c->expr2;
/* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
if (c->op == EXEC_ASSIGN
&& c->expr1->expr_type == EXPR_VARIABLE
&& c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ)
return false;
/* Don't allow an intrinsic assignment to be replaced. */
if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
&& (rhs->rank == 0 || rhs->rank == lhs->rank)

21
gcc/fortran/invoke.texi
View File

@ -116,13 +116,13 @@ by type. Explanations are in the following sections.
@table @emph
@item Fortran Language Options
@xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
@gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol
-fd-lines-as-comments -fdec -fdec-structure -fdec-intrinsic-ints @gol
-fdec-static -fdec-math -fdec-include -fdec-format-defaults @gol
-fdec-blank-format-item -fdefault-double-8 -fdefault-integer-8 @gol
-fdefault-real-8 -fdefault-real-10 -fdefault-real-16 -fdollar-ok @gol
-ffixed-line-length-@var{n} -ffixed-line-length-none -fpad-source @gol
-ffree-form -ffree-line-length-@var{n} -ffree-line-length-none @gol
@gccoptlist{-fall-intrinsics -fallow-invalid-boz -fbackslash -fcray-pointer @gol
-fd-lines-as-code -fd-lines-as-comments -fdec -fdec-structure @gol
-fdec-intrinsic-ints -fdec-static -fdec-math -fdec-include @gol
-fdec-format-defaults -fdec-blank-format-item -fdefault-double-8 @gol
-fdefault-integer-8 -fdefault-real-8 -fdefault-real-10 -fdefault-real-16 @gol
-fdollar-ok @gol -ffixed-line-length-@var{n} -ffixed-line-length-none @gol
-fpad-source -ffree-form -ffree-line-length-@var{n} -ffree-line-length-none @gol
-fimplicit-none -finteger-4-integer-8 -fmax-identifier-length @gol
-fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp @gol
-freal-4-real-10 -freal-4-real-16 -freal-4-real-8 -freal-8-real-10 @gol
@ -231,6 +231,13 @@ available with @command{gfortran}. As a consequence, @option{-Wintrinsics-std}
will be ignored and no user-defined procedure with the same name as any
intrinsic will be called except when it is explicitly declared @code{EXTERNAL}.
@item -fallow-invalid-boz
@opindex @code{allow-invalid-boz}
A BOZ literal constant can occur in a limited number of context in
standard conforming Fortran. This option degrades an error condition
to a warning, and allows a BOZ literal constant to appear where the
Fortran standard would otherwise prohibits it.
@item -fd-lines-as-code
@itemx -fd-lines-as-comments
@opindex @code{fd-lines-as-code}

4
gcc/fortran/lang.opt
View File

@ -377,6 +377,10 @@ fall-intrinsics
Fortran RejectNegative Var(flag_all_intrinsics)
All intrinsics procedures are available regardless of selected standard.
fallow-invalid-boz
Fortran RejectNegative Var(flag_allow_invalid_boz)
Allow a BOZ literal constant to appear in an invalid context.
fallow-leading-underscore
Fortran Undocumented Var(flag_allow_leading_underscore)
; For internal use only: allow the first character of symbol names to be an underscore

2
gcc/fortran/libgfortran.h
View File

@ -174,6 +174,6 @@ typedef enum
typedef enum
{ BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
BT_ASSUMED, BT_UNION
BT_ASSUMED, BT_UNION, BT_BOZ
}
bt;

6
gcc/fortran/misc.c
View File

@ -100,6 +100,9 @@ gfc_basic_typename (bt type)
case BT_VOID:
p = "VOID";
break;
case BT_BOZ:
p = "BOZ";
break;
case BT_UNKNOWN:
p = "UNKNOWN";
break;
@ -169,6 +172,9 @@ gfc_typename (gfc_typespec *ts)
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
break;
case BT_BOZ:
strcpy (buffer, "BOZ");
break;
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;

99
gcc/fortran/primary.c
View File

@ -189,6 +189,55 @@ match_digits (int signflag, int radix, char *buffer)
return length;
}
/* Convert an integer string to an expression node. */
static gfc_expr *
convert_integer (const char *buffer, int kind, int radix, locus *where)
{
gfc_expr *e;
const char *t;
e = gfc_get_constant_expr (BT_INTEGER, kind, where);
/* A leading plus is allowed, but not by mpz_set_str. */
if (buffer[0] == '+')
t = buffer + 1;
else
t = buffer;
mpz_set_str (e->value.integer, t, radix);
return e;
}
/* Convert a real string to an expression node. */
static gfc_expr *
convert_real (const char *buffer, int kind, locus *where)
{
gfc_expr *e;
e = gfc_get_constant_expr (BT_REAL, kind, where);
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
}
/* Convert a pair of real, constant expression nodes to a single
complex expression node. */
static gfc_expr *
convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
{
gfc_expr *e;
e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
GFC_MPC_RND_MODE);
return e;
}
/* Match an integer (digit string and optional kind).
A sign will be accepted if signflag is set. */
@ -231,7 +280,7 @@ match_integer_constant (gfc_expr **result, int signflag)
return MATCH_ERROR;
}
e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
e = convert_integer (buffer, kind, 10, &gfc_current_locus);
e->ts.is_c_interop = is_iso_c;
if (gfc_range_check (e) != ARITH_OK)
@ -337,7 +386,7 @@ cleanup:
static match
match_boz_constant (gfc_expr **result)
{
int radix, length, x_hex, kind;
int radix, length, x_hex;
locus old_loc, start_loc;
char *buffer, post, delim;
gfc_expr *e;
@ -383,9 +432,9 @@ match_boz_constant (gfc_expr **result)
goto backup;
if (x_hex
&& (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
"constant at %C uses non-standard syntax")))
return MATCH_ERROR;
&& gfc_invalid_boz ("Hexadecimal constant at %L uses "
"nonstandard syntax", &gfc_current_locus))
return MATCH_ERROR;
old_loc = gfc_current_locus;
@ -421,8 +470,8 @@ match_boz_constant (gfc_expr **result)
goto backup;
}
if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
"at %C uses non-standard postfix syntax"))
if (gfc_invalid_boz ("BOZ constant at %C uses nonstandard postfix "
"syntax", &gfc_current_locus))
return MATCH_ERROR;
}
@ -436,30 +485,20 @@ match_boz_constant (gfc_expr **result)
if (post == 1)
gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
/* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
"If a data-stmt-constant is a boz-literal-constant, the corresponding
variable shall be of type integer. The boz-literal-constant is treated
as if it were an int-literal-constant with a kind-param that specifies
the representation method with the largest decimal exponent range
supported by the processor." */
kind = gfc_max_integer_kind;
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
/* Mark as boz variable. */
e->is_boz = 1;
if (gfc_range_check (e) != ARITH_OK)
{
gfc_error ("Integer too big for integer kind %i at %C", kind);
gfc_free_expr (e);
return MATCH_ERROR;
}
e = gfc_get_expr ();
e->expr_type = EXPR_CONSTANT;
e->ts.type = BT_BOZ;
e->where = gfc_current_locus;
e->boz.rdx = radix;
e->boz.len = length;
e->boz.str = XCNEWVEC (char, length + 1);
strncpy (e->boz.str, buffer, length);
/* FIXME BOZ. */
if (!gfc_in_match_data ()
&& (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
"statement at %C")))
return MATCH_ERROR;
"statement at %L", &e->where)))
return MATCH_ERROR;
*result = e;
return MATCH_YES;
@ -715,7 +754,7 @@ done:
}
}
e = gfc_convert_real (buffer, kind, &gfc_current_locus);
e = convert_real (buffer, kind, &gfc_current_locus);
if (negate)
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
e->ts.is_c_interop = is_iso_c;
@ -1433,7 +1472,7 @@ match_complex_constant (gfc_expr **result)
if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
gfc_convert_type (imag, &target, 2);
e = gfc_convert_complex (real, imag, kind);
e = convert_complex (real, imag, kind);
e->where = gfc_current_locus;
gfc_free_expr (real);

48
gcc/fortran/resolve.c
View File

@ -10473,44 +10473,32 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
lhs = code->expr1;
rhs = code->expr2;
if (rhs->is_boz
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&code->loc))
return false;
/* Handle the case of a BOZ literal on the RHS. */
if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
if (rhs->ts.type == BT_BOZ)
{
int rc;
if (warn_surprising)
gfc_warning (OPT_Wsurprising,
"BOZ literal at %L is bitwise transferred "
"non-integer symbol %qs", &code->loc,
lhs->symtree->n.sym->name);
if (!gfc_convert_boz (rhs, &lhs->ts))
if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
"statement value nor an actual argument of "
"INT/REAL/DBLE/CMPLX intrinsic subprogram",
&rhs->where))
return false;
if ((rc = gfc_range_check (rhs)) != ARITH_OK)
switch (lhs->ts.type)
{
if (rc == ARITH_UNDERFLOW)
gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rhs->where);
else if (rc == ARITH_OVERFLOW)
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rhs->where);
else if (rc == ARITH_NAN)
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"%<-fno-range-check%>", &rhs->where);
case BT_INTEGER:
if (!gfc_boz2int (rhs, lhs->ts.kind))
return false;
break;
case BT_REAL:
if (!gfc_boz2real (rhs, lhs->ts.kind))
return false;
break;
default:
gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
return false;
}
}
if (lhs->ts.type == BT_CHARACTER
&& warn_character_truncation)
if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
{
HOST_WIDE_INT llen = 0, rlen = 0;
if (lhs->ts.u.cl != NULL

66
gcc/fortran/simplify.c
View File

@ -211,26 +211,6 @@ gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
}
/* In-place convert BOZ to REAL of the specified kind. */
static gfc_expr *
convert_boz (gfc_expr *x, int kind)
{
if (x && x->ts.type == BT_INTEGER && x->is_boz)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_REAL;
ts.kind = kind;
if (!gfc_convert_boz (x, &ts))
return &gfc_bad_expr;
}
return x;
}
/* Test that the expression is a constant array, simplifying if
we are dealing with a parameter array. */
@ -1660,12 +1640,6 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
if (convert_boz (x, kind) == &gfc_bad_expr)
return &gfc_bad_expr;
if (convert_boz (y, kind) == &gfc_bad_expr)
return &gfc_bad_expr;
if (x->expr_type != EXPR_CONSTANT
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
return NULL;
@ -2219,9 +2193,6 @@ gfc_simplify_dble (gfc_expr *e)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
return &gfc_bad_expr;
result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
if (result == &gfc_bad_expr)
return &gfc_bad_expr;
@ -2965,15 +2936,7 @@ gfc_simplify_float (gfc_expr *a)
if (a->expr_type != EXPR_CONSTANT)
return NULL;
if (a->is_boz)
{
if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
return &gfc_bad_expr;
result = gfc_copy_expr (a);
}
else
result = gfc_int2real (a, gfc_default_real_kind);
result = gfc_int2real (a, gfc_default_real_kind);
return range_check (result, "FLOAT");
}
@ -3610,6 +3573,15 @@ simplify_intconv (gfc_expr *e, int kind, const char *name)
{
gfc_expr *result = NULL;
/* Convert BOZ to integer, and return without range checking. */
if (e->ts.type == BT_BOZ)
{
if (!gfc_boz2int (e, kind))
return NULL;
result = gfc_copy_expr (e);
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -6497,6 +6469,21 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
gfc_expr *result = NULL;
int kind;
/* Convert BOZ to real, and return without range checking. */
if (e->ts.type == BT_BOZ)
{
/* Determine kind for conversion of the BOZ. */
if (k)
gfc_extract_int (k, &kind);
else
kind = gfc_default_real_kind;
if (!gfc_boz2real (e, kind))
return NULL;
result = gfc_copy_expr (e);
return result;
}
if (e->ts.type == BT_COMPLEX)
kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
else
@ -6508,9 +6495,6 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
if (convert_boz (e, kind) == &gfc_bad_expr)
return &gfc_bad_expr;
result = gfc_convert_constant (e, BT_REAL, kind);
if (result == &gfc_bad_expr)
return &gfc_bad_expr;

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

@ -769,35 +769,19 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
int index;
unsigned char *buffer;
if (!expr->is_boz)
if (expr->ts.type != BT_INTEGER)
return true;
gcc_assert (expr->expr_type == EXPR_CONSTANT
&& expr->ts.type == BT_INTEGER);
/* Don't convert BOZ to logical, character, derived etc. */
if (ts->type == BT_REAL)
{
buffer_size = size_float (ts->kind);
ts_bit_size = buffer_size * 8;
}
else if (ts->type == BT_COMPLEX)
{
buffer_size = size_complex (ts->kind);
ts_bit_size = buffer_size * 8 / 2;
}
else
return true;
gcc_assert (ts->type == BT_REAL);
buffer_size = size_float (ts->kind);
ts_bit_size = buffer_size * 8;
/* Convert BOZ to the smallest possible integer kind. */
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
if (boz_bit_size > ts_bit_size)
{
gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
&expr->where, (long) boz_bit_size, (long) ts_bit_size);
return false;
}
gcc_assert (boz_bit_size <= ts_bit_size);
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
@ -810,18 +794,9 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
mpz_clear (expr->value.integer);
if (ts->type == BT_REAL)
{
mpfr_init (expr->value.real);
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
}
else
{
mpc_init2 (expr->value.complex, mpfr_get_default_prec());
gfc_interpret_complex (ts->kind, buffer, buffer_size,
expr->value.complex);
}
expr->is_boz = 0;
mpfr_init (expr->value.real);
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
expr->ts.type = ts->type;
expr->ts.kind = ts->kind;

49
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,52 @@
2019-07-23 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.dg/achar_5.f90: Fix for new BOZ handling.
* arithmetic_overflow_1.f90: Ditto.
* gfortran.dg/boz_11.f90: Ditto.
* gfortran.dg/boz_12.f90: Ditto.
* gfortran.dg/boz_4.f90: Ditto.
* gfortran.dg/boz_5.f90: Ditto.
* gfortran.dg/boz_6.f90: Ditto.
* gfortran.dg/boz_7.f90: Ditto.
* gfortran.dg/boz_8.f90: Ditto.
* gfortran.dg/dec_structure_6.f90: Ditto.
* gfortran.dg/dec_union_1.f90: Ditto.
* gfortran.dg/dec_union_2.f90: Ditto.
* gfortran.dg/dec_union_5.f90: Ditto.
* gfortran.dg/dshift_3.f90: Ditto.
* gfortran.dg/gnu_logical_2.f90: Ditto.
* gfortran.dg/int_conv_1.f90: Ditto.
* gfortran.dg/ishft_1.f90: Ditto.
* gfortran.dg/nan_4.f90: Ditto.
* gfortran.dg/no_range_check_3.f90: Ditto.
* gfortran.dg/pr16433.f: Ditto.
* gfortran.dg/pr44491.f90: Ditto.
* gfortran.dg/pr58027.f90: Ditto.
* gfortran.dg/pr81509_2.f90: Ditto.
* gfortran.dg/unf_io_convert_1.f90: Ditto.
* gfortran.dg/unf_io_convert_2.f90: Ditto.
* gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90:
Ditto.
* gfortran.fortran-torture/execute/intrinsic_mvbits.f90: Ditto.
* gfortran.fortran-torture/execute/intrinsic_nearest.f90: Ditto.
* gfortran.fortran-torture/execute/seq_io.f90: Ditto.
* gfortran.dg/gnu_logical_1.F: Delete test.
* gfortran.dg/merge_bits_3.f90: New test.
* gfortran.dg/merge_bits_3.f90: Ditto.
* gfortran.dg/boz_int.f90: Ditto.
* gfortran.dg/boz_bge.f90: Ditto.
* gfortran.dg/boz_complex_1.f90: Ditto.
* gfortran.dg/boz_complex_2.f90: Ditto.
* gfortran.dg/boz_complex_3.f90: Ditto.
* gfortran.dg/boz_dble.f90: Ditto.
* gfortran.dg/boz_dshift_1.f90: Ditto.
* gfortran.dg/boz_dshift_2.f90: Ditto.
* gfortran.dg/boz_float_1.f90: Ditto.
* gfortran.dg/boz_float_2.f90: Ditto.
* gfortran.dg/boz_float_3.f90: Ditto.
* gfortran.dg/boz_iand_1.f90: Ditto.
* gfortran.dg/boz_iand_2.f90: Ditto.
2019-07-23 Jeff Law <law@redhat.com>
PR tree-optimization/86061

5
gcc/testsuite/gfortran.dg/achar_5.f90
View File

@ -37,9 +37,4 @@ program test
print *, char(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" }
print *, achar(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" }
print *, char(z'FFFFFFFF', kind=4)
print *, achar(z'FFFFFFFF', kind=4)
print *, char(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" }
print *, achar(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" }
end program test

6
gcc/testsuite/gfortran.dg/arithmetic_overflow_1.f90
View File

@ -3,8 +3,10 @@
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
! In F2008 and F2018, overflow cannot happen, but a BOZ cannot appear
! in an array constructor.
!
program bug
implicit none
integer(1) :: a(2) = (/ Z'FF', Z'FF' /) ! { dg-error "Arithmetic overflow" }
print*, a
integer(1) :: a(2) = (/ Z'FF', Z'FF' /) ! { dg-error "cannot appear in" }
end program bug

11
gcc/testsuite/gfortran.dg/boz_11.f90
View File

@ -12,16 +12,5 @@ program test0
if (cmplx(b'01000000001010010101001111111101',x,4) /= r) STOP 1
if (cmplx(x,b'01000000001010010101001111111101',4) /= z) STOP 2
if (complex(b'01000000001010010101001111111101',0) /= r) STOP 3
if (complex(0,b'01000000001010010101001111111101') /= z) STOP 4
!if (cmplx(b'00000000000000000000000000000000&
! &01000000001010010101001111111101',x,8) /= rd) STOP 5
!if (cmplx(x,b'00000000000000000000000000000000&
! &01000000001010010101001111111101',8) /= zd) STOP 6
!if (dcmplx(b'00000000000000000000000000000000&
! &01000000001010010101001111111101',x) /= rd) STOP 7
!if (dcmplx(x,b'00000000000000000000000000000000&
! &01000000001010010101001111111101') /= zd) STOP 8
end program test0

7
gcc/testsuite/gfortran.dg/boz_12.f90
View File

@ -4,11 +4,8 @@ program test
implicit none
real x4
double precision x8
x4 = 1.7
x8 = 1.7
write(*,*) complex(x4,z'1FFFFFFFF') ! { dg-error "too" }
write(*,*) cmplx(x8,z'1FFFFFFFFFFFFFFFF') ! { dg-error "too" }
write(*,*) complex(x8,z'1FFFFFFFFFFFFFFFF') ! { dg-error "too" }
write(*,*) dcmplx(x8,z'1FFFFFFFFFFFFFFFF') ! { dg-error "too" }
write(*,*) cmplx(x8,z'1FFFFFFFFFFFFFFFF')
write(*,*) dcmplx(x8,z'1FFFFFFFFFFFFFFFF')
end program test

35
gcc/testsuite/gfortran.dg/boz_4.f90
View File

@ -1,29 +1,20 @@
! { dg-do compile }
! Test that the conversion of a BOZ constant that is too large for the
! integer variable is caught by the compiler.
!
! In F2008 and F2018, overflow cannot happen.
!
program boz
implicit none
integer(1), parameter :: &
& b1 = b'0101010110101010' ! { dg-error "overflow converting" }
integer(2), parameter :: &
& b2 = b'01110000111100001111000011110000' ! { dg-error "overflow converting" }
integer(1), parameter :: b1 = b'0101010110101010'
integer(2), parameter :: b2 = b'01110000111100001111000011110000'
integer(4), parameter :: &
& b4 = b'0111000011110000111100001111000011110000111100001111000011110000' ! { dg-error "overflow converting" }
integer(1), parameter :: &
& o1 = o'1234567076543210' ! { dg-error "overflow converting" }
integer(2), parameter :: &
& o2 = o'1234567076543210' ! { dg-error "overflow converting" }
integer(4), parameter :: &
& o4 = o'1234567076543210' ! { dg-error "overflow converting" }
integer(1), parameter :: &
& z1 = z'deadbeef' ! { dg-error "overflow converting" }
integer(2), parameter :: &
& z2 = z'deadbeef' ! { dg-error "overflow converting" }
integer(4), parameter :: &
& z4 = z'deadbeeffeed' ! { dg-error "overflow converting" }
& b4 = b'0111000011110000111100001111000011110000111100001111000011110000'
integer(1), parameter :: o1 = o'1234567076543210'
integer(2), parameter :: o2 = o'1234567076543210'
integer(4), parameter :: o4 = o'1234567076543210'
integer(1), parameter :: z1 = z'deadbeef'
integer(2), parameter :: z2 = z'deadbeef'
integer(4), parameter :: z4 = z'deadbeeffeed'
end program boz
! { dg-prune-output "BOZ literal at" }

2
gcc/testsuite/gfortran.dg/boz_5.f90
View File

@ -1,4 +1,4 @@
! { dg-do compile }
integer, dimension (2) :: i
i = (/Z'abcde', Z'abcde/) ! { dg-error "Illegal character" }
i = (/Z'abcde', Z'abcde/) ! { dg-error "cannot appear in" }
end

10
gcc/testsuite/gfortran.dg/boz_6.f90
View File

@ -1,13 +1,13 @@
! { dg-do run }
! { dg-options "-std=gnu" }
! { dg-options "-std=gnu -fallow-invalid-boz" }
! PR 24917
program test
integer ib, io, iz, ix
integer jb, jo, jz, jx
data ib, jb /b'111', '111'b/
data io, jo /o'234', '234'o/
data iz, jz /z'abc', 'abc'z/
data ix, jx /x'abc', 'abc'x/
data ib, jb /b'111', '111'b/ ! { dg-warning "nonstandard" }
data io, jo /o'234', '234'o/ ! { dg-warning "nonstandard" }
data iz, jz /z'abc', 'abc'z/ ! { dg-warning "nonstandard" }
data ix, jx /x'abc', 'abc'x/ ! { dg-warning "nonstandard" }
if (ib /= jb) STOP 1
if (io /= jo) STOP 2
if (iz /= jz) STOP 3

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

@ -7,6 +7,6 @@
!
integer :: k, m
integer :: j = z'000abc' ! { dg-error "BOZ used outside a DATA statement" }
data k/x'0003'/ ! { dg-error "uses non-standard syntax" }
data m/'0003'z/ ! { dg-error "uses non-standard postfix syntax" }
data k/x'0003'/ ! { dg-error "nonstandard syntax" }
data m/'0003'z/ ! { dg-error "nonstandard postfix" }
end

6
gcc/testsuite/gfortran.dg/boz_8.f90
View File

@ -11,7 +11,7 @@
real :: r
integer :: i
data i/z'111'/, r/z'4455'/ ! { dg-error "BOZ literal at .1. used to initialize non-integer variable 'r'" }
r = z'FFFF' ! { dg-error "outside a DATA statement" }
i = z'4455' ! { dg-error "outside a DATA statement" }
r = real(z'FFFFFFFFF') ! { dg-error "is too large" }
r = z'FFFF' ! { dg-error "a DATA statement value" }
i = z'4455' ! { dg-error "a DATA statement value" }
r = real(z'FFFFFFFFF')
end

22
gcc/testsuite/gfortran.dg/boz_bge.f90 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do run }
program foo
integer :: k = 4242
if (bge(z'1234', z'5678') .neqv. .false.) stop 1
if (bgt(z'1234', z'5678') .neqv. .false.) stop 2
if (ble(z'1234', z'5678') .eqv. .false.) stop 3
if (blt(z'1234', z'5678') .eqv. .false.) stop 4
if (bge(z'1234', k) .eqv. .false.) stop 5
if (bgt(z'1234', k) .eqv. .false.) stop 6
if (ble(z'1234', k) .neqv. .false.) stop 7
if (blt(z'1234', k) .neqv. .false.) stop 8
if (bge(k, z'5678') .neqv. .false.) stop 9
if (bgt(k, z'5678') .neqv. .false.) stop 10
if (ble(k, z'5678') .eqv. .false.) stop 11
if (blt(k, z'5678') .eqv. .false.) stop 12
end program foo

17
gcc/testsuite/gfortran.dg/boz_complex_1.f90 Normal file
View File

@ -0,0 +1,17 @@
! { dg-do compile }
program foo
implicit none
complex(4) z
z = complex(z'4444', z'4444') ! { dg-error "cannot both be BOZ" }
if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2
z = complex(z'4444', 42) ! { dg-error "cannot appear in the" }
if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2
z = complex(z'44444400', 42.) ! { dg-error "cannot appear in the" }
if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3
end program foo

15
gcc/testsuite/gfortran.dg/boz_complex_2.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
! { dg-options "-fallow-invalid-boz" }
program foo
implicit none
complex(4) z
z = complex(z'4444', 42) ! { dg-warning "cannot appear in the" }
if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2
z = complex(z'44444400', 42.) ! { dg-warning "cannot appear in the" }
if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3
end program foo

15
gcc/testsuite/gfortran.dg/boz_complex_3.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do run }
! { dg-options "-fallow-invalid-boz -w" }
program foo
implicit none
complex(4) z
z = complex(z'4444', 42)
if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2
z = complex(z'44444400', 42.)
if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3
end program foo

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

@ -0,0 +1,6 @@
! { dg-do run }
program foo
double precision x
x = dble(z"400921FB54411744");
if (x /= 3.1415926535_8) stop 1
end

10
gcc/testsuite/gfortran.dg/boz_dshift_1.f90 Normal file
View File

@ -0,0 +1,10 @@
! { dg-do compile }
program foo
integer k, n
k = dshiftl(z'1234',z'2345',1) ! { dg-error "cannot both be BOZ" }
n = dshiftr(z'1234',z'2345',1) ! { dg-error "cannot both be BOZ" }
if (k .eq. n) stop 1
k = dshiftl(z'1234',3.1415,1) ! { dg-error "must be INTEGER" }
n = dshiftr(2.7362,z'2345',1) ! { dg-error "must be INTEGER" }
if (k .eq. n) stop 2
end program foo

12
gcc/testsuite/gfortran.dg/boz_dshift_2.f90 Normal file
View File

@ -0,0 +1,12 @@
! { dg-do run }
program foo
integer k, n
k = dshiftl(z'1234',42,1)
n = dshiftr(z'1234',42,1)
if (k /= 9320) stop 1
if (n /= 21) stop 2
k = dshiftl(42,b'01010101', 1)
n = dshiftr(22,o'12345', 1)
if (k /= 84) stop 1
if (n /= 2674) stop 2
end program foo

4
gcc/testsuite/gfortran.dg/boz_float_1.f90 Normal file
View File

@ -0,0 +1,4 @@
! { dg-do compile }
program foo
print *, float(z'1234') ! { dg-error "cannot appear in" }
end program foo

5
gcc/testsuite/gfortran.dg/boz_float_2.f90 Normal file
View File

@ -0,0 +1,5 @@
! { dg-do compile }
! { dg-options "-fallow-invalid-boz" }
program foo
print *, float(z'1234') ! { dg-warning "cannot appear in" }
end program foo

7
gcc/testsuite/gfortran.dg/boz_float_3.f90 Normal file
View File

@ -0,0 +1,7 @@
! { dg-do run }
! { dg-options "-fallow-invalid-boz -w" }
program foo
integer i
i = float(z'1234')
if (i /= 4660.0) stop 1
end program foo

10
gcc/testsuite/gfortran.dg/boz_iand_1.f90 Normal file
View File

@ -0,0 +1,10 @@
! { dg-do compile }
program foo
print *, iand(z'1234', z'3456') ! { dg-error "cannot both be" }
print *, and(z'1234', z'3456') ! { dg-error "cannot both be" }
print *, ieor(z'1234', z'3456') ! { dg-error "cannot both be" }
print *, xor(z'1234', z'3456') ! { dg-error "cannot both be" }
print *, ior(z'1234', z'3456') ! { dg-error "cannot both be" }
print *, or(z'1234', z'3456') ! { dg-error "cannot both be" }
end program foo

17
gcc/testsuite/gfortran.dg/boz_iand_2.f90 Normal file
View File

@ -0,0 +1,17 @@
! { dg-do run }
program foo
integer :: k = 42
n = iand(k, z'3456'); if (n /= 2) stop 1
n = iand(z'1234', k); if (n /= 32) stop 2
n = and(k, z'3456'); if (n /= 2) stop 3
n = and(z'1234', k); if (n /= 32) stop 4
n = ieor(k, z'3456'); if (n /= 13436) stop 5
n = ieor(z'1234', k); if (n /= 4638) stop 6
n = xor(k, z'3456'); if (n /= 13436) stop 7
n = xor(z'1234', k); if (n /= 4638) stop 8
n = ior(k, z'3456'); if (n /= 13438) stop 9
n = ior(z'1234', k); if (n /= 4670) stop 10
n = or(k, z'3456'); if (n /= 13438) stop 11
n = or(z'1234', k); if (n /= 4670) stop 12
end program foo

13
gcc/testsuite/gfortran.dg/boz_int.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do run }
program foo
implicit none
integer(1) i1
integer(2) i2
integer(4) i4, j4
integer(8) i8
i1 = int(z'12', 1); if (i1 /= 18) stop 1
i2 = int(z'1234', 2); if (i2 /= 4660) stop 2
i4 = int(z'1234', 4); if (i4 /= 4660) stop 3
j4 = int(z'1234'); if (i4 /= 4660) stop 4
i8 = int(z'1233456',8); if (i8 /= 19084374_8) stop 5
end program

2
gcc/testsuite/gfortran.dg/dec_structure_6.f90
View File

@ -41,6 +41,6 @@ if ( r8.o(1) /= 9 .or. r8.o(2) /= 9 .or. r8.o(3) /= 9 ) call aborts ("r8.o")
if ( r8.p(1,1) /= 1 .or. r8.p(2,1) /= 2 .or. r8.p(1,2) /= 3 &
.or. r8.p(2,2) /= 4) &
call aborts ("r8.p")
if ( r8.canary /= z'3D3D3D3D' ) call aborts ("r8.canary")
if ( r8.canary /= int(z'3D3D3D3D') ) call aborts ("r8.canary")
end

6
gcc/testsuite/gfortran.dg/dec_union_1.f90
View File

@ -28,8 +28,8 @@ subroutine sub ()
end union
end structure
record /s6/ r6
r6.ibuf(1) = z'badbeef'
r6.ibuf(2) = z'badbeef'
r6.ibuf(1) = int(z'badbeef')
r6.ibuf(2) = int(z'badbeef')
end subroutine
! Repeat definition from subroutine sub with different size parameter.
@ -55,7 +55,7 @@ integer :: r6_canary = 0
! Copied type declaration - this should not cause problems
i = 1
do while (i < siz)
r6.ibuf(i) = z'badbeef'
r6.ibuf(i) = int(z'badbeef')
i = i + 1
end do

7
gcc/testsuite/gfortran.dg/dec_union_2.f90
View File

@ -31,6 +31,7 @@ structure /s1/
end map
end union
end structure
structure /s2/
union ! U2
map ! M4
@ -51,9 +52,9 @@ r1.b = 1.33e7
if ( r1.a .eq. 0 ) call aborts ("basic union 1")
! Endian-agnostic runtime check
r2.long = z'12345678'
if (.not. ( (r2.w1 .eq. z'1234' .and. r2.w2 .eq. z'5678') &
.or. (r2.w1 .eq. z'5678' .and. r2.w2 .eq. z'1234')) ) then
r2.long = int(z'12345678')
if (.not. ( (r2.w1 .eq. int(z'1234',2) .and. r2.w2 .eq. int(z'5678',2)) &
.or. (r2.w1 .eq. int(z'5678',2) .and. r2.w2 .eq. int(z'1234',2))) ) then
call aborts ("basic union 2")
endif

10
gcc/testsuite/gfortran.dg/dec_union_5.f90
View File

@ -25,11 +25,11 @@ end structure
record /s5/ r5
! Unions with arrays
r5.a(1) = z'41'
r5.a(2) = z'42'
r5.a(3) = z'43'
r5.a(4) = z'44'
r5.a(5) = z'45'
r5.a(1) = int(z'41',1)
r5.a(2) = int(z'42',1)
r5.a(3) = int(z'43',1)
r5.a(4) =int( z'44',1)
r5.a(5) = int(z'45',1)
if ( r5.s(1) .ne. 'A' &
.or. r5.s(2) .ne. 'B' &
.or. r5.s(3) .ne. 'C' &

2
gcc/testsuite/gfortran.dg/dshift_3.f90
View File

@ -17,7 +17,6 @@ subroutine foo(i, j, k)
print *, dshiftl(i, k, 10) ! { dg-error "must be the same type and kind" }
print *, dshiftl(k, j, 10) ! { dg-error "must be the same type and kind" }
print *, dshiftl(i, j, k)
print *, dshiftl(i, j, z'd')
print *, dshiftr(i, j, 134) ! { dg-error "must be less than or equal" }
print *, dshiftr(z'FFF', j, 134) ! { dg-error "must be less than or equal" }
@ -29,6 +28,5 @@ subroutine foo(i, j, k)
print *, dshiftr(i, k, 10) ! { dg-error "must be the same type and kind" }
print *, dshiftr(k, j, 10) ! { dg-error "must be the same type and kind" }
print *, dshiftr(i, j, k)
print *, dshiftr(i, j, z'd')
end subroutine foo

91
gcc/testsuite/gfortran.dg/gnu_logical_1.F
View File

@ -1,91 +0,0 @@
! Testcases for the AND, OR and XOR functions (GNU intrinsics).
! { dg-do run }
! { dg-options "-ffixed-line-length-none" }
integer(kind=1) i1, j1
integer(kind=2) i2, j2
integer i4, j4
integer(kind=8) i8, j8
logical(kind=1) l1, k1
logical(kind=2) l2, k2
logical l4, k4
logical(kind=8) l8, k8
#define TEST_INTEGER(u,ukind,v,vkind) \
ukind = u;\
vkind = v;\
if (iand(u,v) /= and(ukind, vkind)) STOP 1;\
if (iand(u,v) /= and(vkind, ukind)) STOP 1;\
if (ieor(u,v) /= xor(ukind, vkind)) STOP 1;\
if (ieor(u,v) /= xor(vkind, ukind)) STOP 1;\
if (ior(u,v) /= or(ukind, vkind)) STOP 1;\
if (ior(u,v) /= or(vkind, ukind)) STOP 1
TEST_INTEGER(19,i1,6,j1)
TEST_INTEGER(19,i1,6,j2)
TEST_INTEGER(19,i1,6,j4)
TEST_INTEGER(19,i1,6,j8)
TEST_INTEGER(19,i2,6,j1)
TEST_INTEGER(19,i2,6,j2)
TEST_INTEGER(19,i2,6,j4)
TEST_INTEGER(19,i2,6,j8)
TEST_INTEGER(19,i4,6,j1)
TEST_INTEGER(19,i4,6,j2)
TEST_INTEGER(19,i4,6,j4)
TEST_INTEGER(19,i4,6,j8)
TEST_INTEGER(19,i8,6,j1)
TEST_INTEGER(19,i8,6,j2)
TEST_INTEGER(19,i8,6,j4)
TEST_INTEGER(19,i8,6,j8)
#define TEST_LOGICAL(u,ukind,v,vkind) \
ukind = u;\
vkind = v;\
if ((u .and. v) .neqv. and(ukind, vkind)) STOP 1;\
if ((u .and. v) .neqv. and(vkind, ukind)) STOP 1;\
if (((u .and. .not. v) .or. (.not. u .and. v)) .neqv. xor(ukind, vkind)) STOP 1;\
if (((u .and. .not. v) .or. (.not. u .and. v)) .neqv. xor(vkind, ukind)) STOP 1;\
if ((u .or. v) .neqv. or(ukind, vkind)) STOP 1;\
if ((u .or. v) .neqv. or(vkind, ukind)) STOP 2
TEST_LOGICAL(.true.,l1,.false.,k1)
TEST_LOGICAL(.true.,l1,.true.,k1)
TEST_LOGICAL(.true.,l1,.false.,k2)
TEST_LOGICAL(.true.,l1,.true.,k2)
TEST_LOGICAL(.true.,l1,.false.,k4)
TEST_LOGICAL(.true.,l1,.true.,k4)
TEST_LOGICAL(.true.,l1,.false.,k8)
TEST_LOGICAL(.true.,l1,.true.,k8)
TEST_LOGICAL(.true.,l2,.false.,k1)
TEST_LOGICAL(.true.,l2,.true.,k1)
TEST_LOGICAL(.true.,l2,.false.,k2)
TEST_LOGICAL(.true.,l2,.true.,k2)
TEST_LOGICAL(.true.,l2,.false.,k4)
TEST_LOGICAL(.true.,l2,.true.,k4)
TEST_LOGICAL(.true.,l2,.false.,k8)
TEST_LOGICAL(.true.,l2,.true.,k8)
TEST_LOGICAL(.true.,l4,.false.,k1)
TEST_LOGICAL(.true.,l4,.true.,k1)
TEST_LOGICAL(.true.,l4,.false.,k2)
TEST_LOGICAL(.true.,l4,.true.,k2)
TEST_LOGICAL(.true.,l4,.false.,k4)
TEST_LOGICAL(.true.,l4,.true.,k4)
TEST_LOGICAL(.true.,l4,.false.,k8)
TEST_LOGICAL(.true.,l4,.true.,k8)
TEST_LOGICAL(.true.,l8,.false.,k1)
TEST_LOGICAL(.true.,l8,.true.,k1)
TEST_LOGICAL(.true.,l8,.false.,k2)
TEST_LOGICAL(.true.,l8,.true.,k2)
TEST_LOGICAL(.true.,l8,.false.,k4)
TEST_LOGICAL(.true.,l8,.true.,k4)
TEST_LOGICAL(.true.,l8,.false.,k8)
TEST_LOGICAL(.true.,l8,.true.,k8)
end

24
gcc/testsuite/gfortran.dg/gnu_logical_2.f90
View File

@ -7,23 +7,23 @@
print *, and(i,i)
print *, and(l,l)
print *, and(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
print *, and(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
print *, and(i,l) ! { dg-error "must have the same type" }
print *, and(l,i) ! { dg-error "must have the same type" }
print *, and(i,r) ! { dg-error "must be the same type" }
print *, and(c,l) ! { dg-error "must be the same type" }
print *, and(i,l) ! { dg-error "must be the same type" }
print *, and(l,i) ! { dg-error "must be the same type" }
print *, or(i,i)
print *, or(l,l)
print *, or(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
print *, or(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
print *, or(i,l) ! { dg-error "must have the same type" }
print *, or(l,i) ! { dg-error "must have the same type" }
print *, or(i,r) ! { dg-error "must be the same type" }
print *, or(c,l) ! { dg-error "must be the same type" }
print *, or(i,l) ! { dg-error "must be the same type" }
print *, or(l,i) ! { dg-error "must be the same type" }
print *, xor(i,i)
print *, xor(l,l)
print *, xor(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
print *, xor(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
print *, xor(i,l) ! { dg-error "must have the same type" }
print *, xor(l,i) ! { dg-error "must have the same type" }
print *, xor(i,r) ! { dg-error "must be the same type" }
print *, xor(c,l) ! { dg-error "must be the same type" }
print *, xor(i,l) ! { dg-error "must be the same type" }
print *, xor(l,i) ! { dg-error "must be the same type" }
end

21
gcc/testsuite/gfortran.dg/int_conv_1.f90
View File

@ -1,36 +1,25 @@
! { dg-do run }
! { dg-options "-std=gnu" }
integer(kind=2) :: i2, j2, k2, l2, m2, n2, o2
integer(kind=4) :: i4, j4
integer(kind=8) :: i8, j8
integer(kind=2) :: i2, k2, l2
integer(kind=8) :: i8
real :: x
complex :: z
i2 = huge(i2) / 3
i8 = int8(i2)
i4 = long(i2)
j2 = short(i2)
k2 = int2(i2)
l2 = int2(i8)
m2 = short(i8)
n2 = int2(i4)
o2 = short(i4)
if (i8 /= i2 .or. i4 /= i2 .or. j2 /= i2 .or. k2 /= i2 &
.or. l2 /= i2 .or. m2 /= i2 .or. n2 /= i2 .or. o2 /= i2) STOP 1
if (i8 /= i2 .or. k2 /= i2 .or. l2 /= i2 ) STOP 1
x = i2
i8 = int8(x)
i4 = long(x)
j2 = short(x)
k2 = int2(x)
if (i8 /= i2 .or. i4 /= i2 .or. j2 /= i2 .or. k2 /= i2) STOP 2
if (i8 /= i2 .or. k2 /= i2) STOP 2
z = i2 + (0.,-42.)
i8 = int8(z)
i4 = long(z)
j2 = short(z)
k2 = int2(z)
if (i8 /= i2 .or. i4 /= i2 .or. j2 /= i2 .or. k2 /= i2) STOP 3
if (i8 /= i2 .or. k2 /= i2) STOP 3
end

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

@ -25,7 +25,6 @@ if (ishft (1_8, 0) /= 1) STOP 19
if (ishft (1_8, 1) /= 2) STOP 20
if (ishft (3_8, 1) /= 6) STOP 21
if (ishft (-1_8, 1) /= -2) STOP 22
if (ishft (-1_8, -60) /= z'F') STOP 23
if (ishftc (1_1, 0) /= 1) STOP 24
if (ishftc (1_1, 1) /= 2) STOP 25

5
gcc/testsuite/gfortran.dg/merge_bits_3.f90 Normal file
View File

@ -0,0 +1,5 @@
! { dg-do compile }
program foo
integer m
m = merge_bits(b'010101', b"101010", 42) ! { dg-error "cannot both be" }
end program foo

7
gcc/testsuite/gfortran.dg/merge_bits_4.f90 Normal file
View File

@ -0,0 +1,7 @@
! { dg-do run }
program foo
integer m, n, k
m = merge_bits(b'010101', 1234, 42); if (m /= 1232) stop 1
n = merge_bits(1234, z'3456', 42); if (n /= 13398) stop 2
k = merge_bits(1234, 3456, o'12334'); if (k /= 3536) stop 3
end program foo

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

@ -1,5 +1,5 @@
! { dg-do compile }
! { dg-options "-std=gnu" }
! { dg-options "-std=gnu -fallow-invalid-boz" }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
@ -9,8 +9,8 @@
!
program test
implicit none
real(4), parameter :: r0 = z'FFFFFFFF' ! { dg-error "Arithmetic NaN" }
real(4), parameter :: r0 = z'FFFFFFFF'
real(4) r
data r/z'FFFFFFFF'/ ! { dg-error "Arithmetic NaN" }
r = z'FFFFFFFF' ! { dg-error "Arithmetic NaN" }
data r/z'FFFFFFFF'/
r = z'FFFFFFFF' ! { dg-warning "neither a DATA statement value" }
end program test

6
gcc/testsuite/gfortran.dg/no_range_check_3.f90
View File

@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fno-range-check" }
program test
integer(2) :: j, k
integer :: i
i = int(z'FFFFFFFF',kind(i))
if (i /= -1) STOP 1
@ -9,4 +9,8 @@ program test
if (popcnt(int(z'0F00F00080000001',8)) /= 10) STOP 3
if (popcnt(int(z'800F0001',4)) /= 6) STOP 4
j = -1234_2
k = int(z'FB2E',kind(j))
if (k /= j) STOP 5
if (int(z'FB2E',kind(j)) /= j) STOP 6
end program test

4
gcc/testsuite/gfortran.dg/pr16433.f
View File

@ -1,6 +1,6 @@
! { dg-do compile }
real x
double precision dx
data x/x'2ffde'/ ! { dg-warning "Hexadecimal constant | used to initialize non-integer" }
dx = x ! { dg-bogus "exadecimal constant" "Hex constant where there is none" }
data x/x'2ffde'/ ! { dg-error "Hexadecimal constant" }
dx = x
end

2
gcc/testsuite/gfortran.dg/pr44491.f90
View File

@ -1,5 +1,5 @@
! { dg-do compile }
! { dg-options "-std=gnu" }
! PR fortran/44491
character*2 escape /z'1B'/ ! { dg-error "Incompatible types in DATA" }
character*2 escape /z'1B'/ ! { dg-error "cannot appear in" }
end

2
gcc/testsuite/gfortran.dg/pr58027.f90
View File

@ -1,5 +1,5 @@
! { dg-do compile }
! PR fortran/58027
integer, parameter :: i(1)=(/z'ff800000'/) ! { dg-error "overflow converting" }
integer, parameter :: i(1)=(/z'ff800000'/) ! { dg-error "cannot appear in" }
print *, isclass
end

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

@ -12,7 +12,7 @@ k = and(i, z'1234')
k = ieor(z'ade',i)
k = ior(i,z'1111')
k = ior(i,k) ! { dg-error "different kind type parameters" }
k = and(i,k)
k = and(a,z'1234') ! { dg-error "must have the same type" }
k = and(i,k) ! { dg-error "must be the same type" }
k = and(a,z'1234') ! { dg-error "must be the same type" }
end program foo

12
gcc/testsuite/gfortran.dg/unf_io_convert_1.f90
View File

@ -18,9 +18,9 @@ program main
integer i
character(4) str
m(1) = Z'11223344' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
m(2) = Z'55667788' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
n = Z'77AABBCC' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
m(1) = int(Z'11223344')
m(2) = int(Z'55667788')
n = int(Z'77AABBCC')
str = 'asdf'
do i = 1,size
r(i) = i
@ -46,7 +46,7 @@ program main
read(9) str
!
! check results
if (m(1).ne.Z'11223344') then
if (m(1).ne.int(Z'11223344')) then
if (debug) then
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
else
@ -54,7 +54,7 @@ program main
endif
endif
if (m(2).ne.Z'55667788') then
if (m(2).ne.int(Z'55667788')) then
if (debug) then
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
else
@ -62,7 +62,7 @@ program main
endif
endif
if (n.ne.Z'77AABBCC') then
if (n.ne.int(Z'77AABBCC')) then
if (debug) then
print '(A,Z8)','n incorrect. n = ',n
else

12
gcc/testsuite/gfortran.dg/unf_io_convert_2.f90
View File

@ -15,26 +15,28 @@ program main
close(10,status="delete")
open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" }
i = (/ Z'11223344', Z'55667700' /)
i = (/ int(Z'11223344'), int(Z'55667700') /)
write (10) i
rewind (10)
read (10) b
if (any(b /= (/ Z'11', Z'22', Z'33', Z'44', Z'55', Z'66', Z'77', Z'00' /))) &
if (any(b /= (/ int(Z'11',1), int(Z'22',1), int(Z'33',1), int(Z'44',1), &
& int(Z'55',1), int(Z'66',1), int(Z'77',1), int(Z'00',1) /))) &
STOP 2
backspace 10
read (10) j
if (j /= Z'1122334455667700') STOP 3
if (j /= int(Z'1122334455667700',8)) STOP 3
close (10, status="delete")
open (10, form="unformatted", convert="little_endian") ! { dg-warning "Extension: CONVERT" }
write (10) i
rewind (10)
read (10) b
if (any(b /= (/ Z'44', Z'33', Z'22', Z'11', Z'00', Z'77', Z'66', Z'55' /))) &
if (any(b /= (/ int(Z'44',1), int(Z'33',1), int(Z'22',1), int(Z'11',1), &
& int(Z'00',1), int(Z'77',1), int(Z'66',1), int(Z'55',1) /))) &
STOP 4
backspace 10
read (10) j
if (j /= Z'5566770011223344') STOP 5
if (j /= int(Z'5566770011223344',8)) STOP 5
close (10, status="delete")
end program main

18
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90
View File

@ -13,25 +13,25 @@ program test_exponent_fraction
x = 0.
call test_4(x)
i = o'00000000001'
i = int(o'00000000001')
call test_4(x)
i = o'00010000000'
i = int(o'00010000000')
call test_4(x)
i = o'17700000000'
i = int(o'17700000000')
call test_4(x)
i = o'00004000001'
i = int(o'00004000001')
call test_4(x)
i = o'17737777777'
i = int(o'17737777777')
call test_4(x)
i = o'10000000000'
i = int(o'10000000000')
call test_4(x)
i = o'0000010000'
i = int(o'0000010000')
call test_4(x)
y = 0.5
@ -40,7 +40,7 @@ program test_exponent_fraction
y = 0.
call test_8(y)
j = o'00000000001'
j = int(o'00000000001',8)
call test_8(y)
y = 0.2938735877D-38
@ -49,7 +49,7 @@ program test_exponent_fraction
y = -1.469369D-39
call test_8(y)
y = z'7fe00000'
y = real(z'7fe00000',8)
call test_8(y)
y = -5.739719D+42

4
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mvbits.f90
View File

@ -10,7 +10,7 @@ CALL mvbits(from, 2, 16, to, 1)
if (to /= result) STOP 1
to8 = 0_8
from8 = b'1011'*2_8**32
from8 = int(b'1011',8)*2_8**32
call mvbits (from8, 33, 3, to8, 2)
if (to8 /= b'10100') STOP 1
if (to8 /= int(b'10100',8)) STOP 1
end

11
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90
View File

@ -11,13 +11,13 @@ program test_nearest
s = 3.0
call test_n (s, r)
i = z'00800000'
i = int(z'00800000')
call test_n (s, r)
i = z'007fffff'
i = int(z'007fffff')
call test_n (s, r)
i = z'00800100'
i = int(z'00800100')
call test_n (s, r)
s = 0
@ -25,9 +25,8 @@ program test_nearest
y = nearest(s, -r)
if (.not. (x .gt. s .and. y .lt. s )) STOP 1
! ??? This is pretty sketchy, but passes on most targets.
infi = z'7f800000'
maxi = z'7f7fffff'
infi = int(z'7f800000')
maxi = int(z'7f7fffff')
call test_up(max, inf)
call test_up(-inf, -max)

12
gcc/testsuite/gfortran.fortran-torture/execute/seq_io.f90
View File

@ -16,9 +16,9 @@
integer n
real*4 r(size)
integer i
m(1) = Z'11111111'
m(2) = Z'22222222'
n = Z'33333333'
m(1) = int(Z'11111111')
m(2) = int(Z'22222222')
n = int(Z'33333333')
do i = 1,size
r(i) = i
end do
@ -39,7 +39,7 @@
read(9)r
!
! check results
if (m(1).ne.Z'11111111') then
if (m(1).ne. int(Z'11111111')) then
if (debug) then
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
else
@ -47,7 +47,7 @@
endif
endif
if (m(2).ne.Z'22222222') then
if (m(2).ne. int(Z'22222222')) then
if (debug) then
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
else
@ -55,7 +55,7 @@
endif
endif
if (n.ne.Z'33333333') then
if (n.ne. int(Z'33333333')) then
if (debug) then
print '(A,Z8)','n incorrect. n = ',n
else

5
libgomp/ChangeLog
View File

@ -1,3 +1,8 @@
2019-07-23 Steven G. Kargl <kargl@gcc.gnu.org>
* testsuite/libgomp.fortran/reduction4.f90: Update BOZ usage
* testsuite/libgomp.fortran/reduction5.f90: Ditto.
2019-07-20 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.c-c++-common/loop-1.c: New test.

56
libgomp/testsuite/libgomp.fortran/reduction4.f90
View File

@ -4,12 +4,12 @@
integer (kind = 4) :: i, ia (6), j, ja (6), k, ka (6), ta (6), n, cnt, x
logical :: v
i = Z'ffff0f'
ia = Z'f0ff0f'
j = Z'0f0000'
ja = Z'0f5a00'
k = Z'055aa0'
ka = Z'05a5a5'
i = int(Z'ffff0f')
ia = int(Z'f0ff0f')
j = int(Z'0f0000')
ja = int(Z'0f5a00')
k = int(Z'055aa0')
ka = int(Z'05a5a5')
v = .false.
cnt = -1
x = not(0)
@ -22,35 +22,35 @@
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = Z'ff7fff'
ia(3:5) = Z'fffff1'
j = Z'078000'
i = int(Z'ff7fff')
ia(3:5) = int(Z'fffff1')
j = int(Z'078000')
ja(1:3) = 1
k = Z'78'
ka(3:6) = Z'f0f'
k = int(Z'78')
ka(3:6) = int(Z'f0f')
else if (n .eq. 1) then
i = Z'ffff77'
ia(2:5) = Z'ffafff'
j = Z'007800'
i = int(Z'ffff77')
ia(2:5) = int(Z'ffafff')
j = int(Z'007800')
ja(2:5) = 8
k = Z'57'
ka(3:4) = Z'f0108'
k = int(Z'57')
ka(3:4) = int(Z'f0108')
else
i = Z'777fff'
ia(1:2) = Z'fffff3'
j = Z'000780'
ja(5:6) = Z'f00'
k = Z'1000'
ka(6:6) = Z'777'
i = int(Z'777fff')
ia(1:2) = int(Z'fffff3')
j = int(Z'000780')
ja(5:6) = int(Z'f00')
k = int(Z'1000')
ka(6:6) = int(Z'777')
end if
!$omp end parallel
if (v) STOP 1
if (cnt .eq. 3) then
ta = (/Z'f0ff03', Z'f0af03', Z'f0af01', Z'f0af01', Z'f0af01', Z'f0ff0f'/)
if (i .ne. Z'777f07' .or. any (ia .ne. ta)) STOP 2
ta = (/Z'f5a01', Z'f5a09', Z'f5a09', Z'f5a08', Z'f5f08', Z'f5f00'/)
if (j .ne. Z'fff80' .or. any (ja .ne. ta)) STOP 3
ta = (/Z'5a5a5', Z'5a5a5', Z'aaba2', Z'aaba2', Z'5aaaa', Z'5addd'/)
if (k .ne. Z'54a8f' .or. any (ka .ne. ta)) STOP 4
ta = (/int(Z'f0ff03'), int(Z'f0af03'), int(Z'f0af01'), int(Z'f0af01'), int(Z'f0af01'), int(Z'f0ff0f')/)
if (i .ne. int(Z'777f07') .or. any (ia .ne. ta)) STOP 2
ta = (/int(Z'f5a01'), int(Z'f5a09'), int(Z'f5a09'), int(Z'f5a08'), int(Z'f5f08'), int(Z'f5f00')/)
if (j .ne. int(Z'fff80') .or. any (ja .ne. ta)) STOP 3
ta = (/int(Z'5a5a5'), int(Z'5a5a5'), int(Z'aaba2'), int(Z'aaba2'), int(Z'5aaaa'), int(Z'5addd')/)
if (k .ne. int(Z'54a8f') .or. any (ka .ne. ta)) STOP 4
end if
end

10
libgomp/testsuite/libgomp.fortran/reduction5.f90
View File

@ -10,15 +10,15 @@ contains
subroutine test1
use reduction5, bitwise_or => ior
integer :: n
n = Z'f'
n = int(Z'f')
!$omp parallel sections num_threads (3) reduction (bitwise_or: n)
n = ior (n, Z'20')
n = ior (n, int(Z'20'))
!$omp section
n = bitwise_or (Z'410', n)
n = bitwise_or (int(Z'410'), n)
!$omp section
n = bitwise_or (n, Z'2000')
n = bitwise_or (n, int(Z'2000'))
!$omp end parallel sections
if (n .ne. Z'243f') STOP 1
if (n .ne. int(Z'243f')) STOP 1
end subroutine
subroutine test2
use reduction5, min => max, max => min