+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
}
-/* 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 *****/
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);
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;
}
#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. */
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;
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;
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;
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;
&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 "
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))
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;
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;
return true;
}
-
-static bool
-boz_args_check(gfc_expr *i, gfc_expr *j)
+bool
+gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
{
- 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;
+ /* i and j cannot both be BOZ literal constants. */
+ if (!boz_args_check (i, j))
+ return false;
- }
- return true;
-}
+ /* 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;
-bool
-gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
-{
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))
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;
}
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;
bool
gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
{
- if (!type_check (i, 0, BT_INTEGER))
+ /* i and j cannot both be BOZ literal constants. */
+ if (!boz_args_check (i, j))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ /* 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 (!boz_args_check (i, j))
+ /* 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 (i->is_boz) i->ts.kind = j->ts.kind;
- if (j->is_boz) j->ts.kind = i->ts.kind;
+ if (!type_check (j, 1, BT_INTEGER))
+ return false;
if (i->ts.kind != j->ts.kind)
{
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;
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;
bool
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
{
- if (!type_check (i, 0, BT_INTEGER))
+ /* i and j cannot both be BOZ literal constants. */
+ if (!boz_args_check (i, j))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ /* 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 (!boz_args_check (i, j))
+ /* 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 (i->is_boz) i->ts.kind = j->ts.kind;
- if (j->is_boz) j->ts.kind = i->ts.kind;
+ if (!type_check (i, 0, BT_INTEGER))
+ return false;
- if (!type_check (mask, 2, BT_INTEGER))
+ if (!type_check (j, 1, BT_INTEGER))
return false;
if (!same_type_check (i, 0, j, 1))
return false;
- if (!same_type_check (i, 0, mask, 2))
+ if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
+ return false;
+
+ if (!type_check (mask, 2, BT_INTEGER))
return false;
- if (mask->is_boz) mask->ts.kind = i->ts.kind;
+ if (!same_type_check (i, 0, mask, 2))
+ return false;
return true;
}
}
-/* 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;
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;
- }
-
- 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;
- }
+ /* i and j cannot both be BOZ literal constants. */
+ if (!boz_args_check (i, j))
+ 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 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 (!scalar_check (i, 0))
+ /* 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 (!scalar_check (j, 1))
+ if (!same_type_check (i, 0, j, 1, false))
return false;
- if (!boz_args_check (i, j))
+ if (!scalar_check (i, 0))
return false;
- if (i->is_boz) i->ts.kind = j->ts.kind;
- if (j->is_boz) j->ts.kind = i->ts.kind;
+ if (!scalar_check (j, 1))
+ return false;
return true;
}
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);
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");
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. */
&& !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)
- {
- 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;
- }
+ if (rvalue->ts.type == BT_BOZ)
+ {
+ /* 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)
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. */
}
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;
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);
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)
@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
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}
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
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;
case BT_VOID:
p = "VOID";
break;
+ case BT_BOZ:
+ p = "BOZ";
+ break;
case BT_UNKNOWN:
p = "UNKNOWN";
break;
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
break;
+ case BT_BOZ:
+ strcpy (buffer, "BOZ");
+ break;
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;
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. */
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)
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;
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;
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;
}
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;
}
}
- 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;
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);
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)
- {
- 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);
+
+ switch (lhs->ts.type)
+ {
+ 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
}
-/* 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. */
{
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;
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;
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");
}
{
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;
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
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;
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)
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;
+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
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
!
! 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
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
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
! { 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" }
! { 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
! { 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
!
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
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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do run }
+program foo
+ double precision x
+ x = dble(z"400921FB54411744");
+ if (x /= 3.1415926535_8) stop 1
+end
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do compile }
+program foo
+ print *, float(z'1234') ! { dg-error "cannot appear in" }
+end program foo
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fallow-invalid-boz" }
+program foo
+ print *, float(z'1234') ! { dg-warning "cannot appear in" }
+end program foo
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
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
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.
! 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
end map
end union
end structure
+
structure /s2/
union ! U2
map ! M4
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
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' &
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" }
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
-! 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
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
! { 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
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
--- /dev/null
+! { dg-do compile }
+program foo
+ integer m
+ m = merge_bits(b'010101', b"101010", 42) ! { dg-error "cannot both be" }
+end program foo
--- /dev/null
+! { 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
! { 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-*-* } }
!
!
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
! { 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
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
! { 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
! { 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
! { 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
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
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
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
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
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
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
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
y = 0.
call test_8(y)
- j = o'00000000001'
+ j = int(o'00000000001',8)
call test_8(y)
y = 0.2938735877D-38
y = -1.469369D-39
call test_8(y)
- y = z'7fe00000'
+ y = real(z'7fe00000',8)
call test_8(y)
y = -5.739719D+42
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
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
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)
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
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
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
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
+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.
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)
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
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
projects / gcc.git / commitdiff