This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH] Fortran -- Handle BOZ in accordance with F2008/2015.
- From: Steve Kargl <sgk at troutmask dot apl dot washington dot edu>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Fri, 6 Oct 2017 13:34:07 -0700
- Subject: [PATCH] Fortran -- Handle BOZ in accordance with F2008/2015.
- Authentication-results: sourceware.org; auth=none
- Reply-to: sgk at troutmask dot apl dot washington dot edu
All,
I have spent the last few days trying to reconcile the various Fortran
standards' requirements for handling BOZ. The short story is that J3
over the last 27 years has made incompatible changes to the interpretation
of a BOZ (under some circumstances). The interpretations in F2008 and
F2015 now treat a boz-literal-constant as a sequence of bits. Unfortunately,
due to quirks in how BOZ are currently implemented in gfortran and a boat
load of documented and undocumented extensions, bringing gfortran into
agreement with F2008/F2015 led to a rewrite of BOZ handling. In the
rewrite I have made no attempt to use the -std= option to try to maintain
the incompatibilities between standards.
On x86_64-*-freebsd, the attached patch gives
tail gcc/testsuite/gfortran/gfortran.sum
=== gfortran Summary ===
# of expected passes 45888
# of unexpected failures 4
# of unexpected successes 6
# of expected failures 97
# of unsupported tests 79
/home/sgk/gcc/obj/gcc/gfortran version 8.0.0 20170927 (experimental) (GCC)
The 4 unexpected failures are not related to this patch.
2017-10-06 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/45513
PR fortran/54072
PR fortran/81509
* array.c (resolve_array_list): Handle an array descriptor
with BOZ elements.
* check.c (numeric_check): Error for BOZ when numeric type is expected.
(numeric_or_boz_check): New function. Check for numeric or BOZ arg.
(int_or_boz_check): New function. Check for INTEGER or BOZ arg.
(gfc_check_bge_bgt_ble_blt): Use int_or_boz_check.
(gfc_check_cmplx): Use numeric_or_boz_check.
(gfc_check_complex): Permit BOZ arguments.
(gfc_check_dcmplx): Use numeric_or_boz_check.
(gfc_check_dble): Allow BOZ argument.
(boz_args_check): New function. Disallow two BOZ arguments.
(gfc_boz2int): New function. In-place conversion of BOZ to INTEGER.
(gfc_check_dshift): Use int_or_boz_check, boz_args_check, gfc_boz2int.
(gfc_check_iand): Renamed to ...
(gfc_check_iand_ieor_ior): ... this. Use int_or_boz_check,
boz_args_check, and gfc_boz2int. Convert gfc_notify_std to gfc_error.
(gfc_check_ieor, gfc_check_ior): Removed function.
(gfc_check_int): Use numeric_or_boz_check
(gfc_check_merge_bits): Use int_or_boz_check, boz_args_check,
gfc_boz2int
(gfc_check_real): Allow BOZ. Use numeric_or_boz_check.
(gfc_check_and): Allow BOZ. Use boz_args_check and gfc_boz2int
* data.c (gfc_assign_data_value): Implement F2008/F2015 sematics for
for BOZ in data statement.
* expr.c (gfc_get_expr): Set boz component of gfc_expr to NULL.
(gfc_copy_expr, free_expr0): Cope new boz component.
(gfc_check_assign): Replace old is_boz checks with BT_BOZ checks.
Use gfc_boz2int.
* gfortran.h (gfc_expr): Remove is_boz component. Add boz
component. Add prototyp gfc_boz2int.
* intrinsic.c (add_functions): Use gfc_check_iand_ieor_ior
in place of gfc_check_iand, gfc_check_ieor, and gfc_check_ior.
* intrinsic.h: Add prototype for gfc_check_iand_ieor_ior.
Remove prototypes for gfc_check_iand, gfc_check_ieor, gfc_check_ior.
* intrinsic.texi: Document (some) changes.
* iresolve.c(gfc_resolve_iand,gfc_resolve_ieor,gfc_resolve_ior): Mark
j with ATTRIBUTE_UNUSED. Make IAND, IEOR, IOR
conform to F2008/2015.
* libgfortran.h: Add new basic type BT_BOZ.
* primary.c (match_boz_constant): Remove old handling of BOZ.
Cache BOZ string in gfc_expr's boz component.
* resolve.c (resolve_operator): Allow BOZ in binary
numeric and rational operators. Use gfc_boz2int or gfc_convert_boz
as needed.
(resolve_allocate_expr): Split declaration and initialization.
(resolve_ordinary_assign): Replace is_boz checks with BT_BOZ checks.
* simplify.c (convert_boz): Replace BT_INTEGER with BT_BOZ
(simplify_cmplx): Rearrange allow simplication of individual args.
Convert BOZ as needed.
(gfc_simplify_complex): Account of args with BT_BOZ.
(gfc_simplify_float): Replace is_boz check with BT_BOZ check.
(simplify_intconv): In-place conversin of boz to INTEGER.
* target-memory.c (boz2int): New function. Conversion of
boz to INTEGER with widest decimal range.
(gfc_convert_boz): Use it. Remove clearly is_boz.
2017-10-06 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/45513
PR fortran/54072
PR fortran/81509
* gfortran.dg/achar_5.f90: Remove BOZ arg tests.
* gfortran.dg/boz_4.f90: Delete test as it no longer applies.
* gfortran.dg/graphite/id-26.f03: Fix test.
* gfortran.dg/pr81509_1.f90: New test.
* gfortran.dg/pr81509_2.f90: New test.
* gfortran.dg/unf_io_convert_2.f90: Fix test.
Index: gcc/fortran/array.c
===================================================================
--- gcc/fortran/array.c (revision 253236)
+++ gcc/fortran/array.c (working copy)
@@ -1896,10 +1896,12 @@ find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr,
static bool
resolve_array_list (gfc_constructor_base base)
{
+ bool saw_boz;
bool t;
gfc_constructor *c;
gfc_iterator *iter;
+ saw_boz = false;
t = true;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
@@ -1942,11 +1944,46 @@ resolve_array_list (gfc_constructor_base base)
if (!gfc_resolve_expr (c->expr))
t = false;
+ if (c->expr->ts.type == BT_BOZ)
+ saw_boz = true;
+
if (UNLIMITED_POLY (c->expr))
{
gfc_error ("Array constructor value at %L shall not be unlimited "
"polymorphic [F2008: C4106]", &c->expr->where);
t = false;
+ }
+ }
+
+ /* If an array contains a BT_BOZ, then array elements need to be converted
+ an INTEGER. This is an GNU Fortran extension. Mixing BOZ and non-BOZ
+ entities is not permitted. */
+ if (saw_boz)
+ {
+ bt type = BT_UNKNOWN;
+
+ c = gfc_constructor_first (base);
+ for (; c; c = gfc_constructor_next (c))
+ if (c->expr->ts.type != BT_BOZ)
+ {
+ gfc_error ("Type mismatch at %L with elements in an array "
+ "constructor due to a boz-literal-constant array element",
+ &c->expr->where);
+ return false;
+ }
+
+ /* All elements are BT_BOZ, so convert to INTEGER. */
+ if (type == BT_UNKNOWN)
+ {
+ gfc_expr *e;
+ c = gfc_constructor_first (base);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ e = gfc_get_constant_expr (BT_INTEGER, gfc_max_integer_kind,
+ &c->expr->where);
+ gfc_boz2int (c->expr, e);
+ gfc_free_expr (e);
+ }
}
}
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 253236)
+++ gcc/fortran/check.c (working copy)
@@ -93,7 +93,47 @@ numeric_check (gfc_expr *e, int n)
error:
- gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
+ if (e->ts.type == BT_BOZ)
+ gfc_error ("%qs argument of %qs intrinsic at %L cannot be a "
+ "boz-literal-constant", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ else
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
+
+ return false;
+}
+
+/* Check that the expression is a numeric type or boz-literal-constant. */
+
+static bool
+numeric_or_boz_check (gfc_expr *e, int n)
+{
+ /* Users sometime use a subroutine designator as an actual argument to
+ an intrinsic subprogram that expects an argument with a numeric type. */
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+ goto error;
+
+ if (e->ts.type == BT_BOZ || e->ts.type == BT_COMPLEX
+ || e->ts.type == BT_INTEGER || e->ts.type == BT_REAL)
+ return true;
+
+ /* If the expression has not got a type, check if its namespace can
+ offer a default type. */
+ if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+ && e->symtree->n.sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
+ && gfc_numeric_ts (&e->symtree->n.sym->ts))
+ {
+ e->ts = e->symtree->n.sym->ts;
+ return true;
+ }
+
+error:
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must either have a numeric "
+ "type or be a boz-literal-constant",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
@@ -118,6 +158,22 @@ int_or_real_check (gfc_expr *e, int n)
}
+/* Check that an expression is integer or boz-literal-constant. */
+
+static bool
+int_or_boz_check (gfc_expr *e, int n)
+{
+ if (e->ts.type != BT_INTEGER && e->ts.type != BT_BOZ)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER or a "
+ "boz-literal-constant", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return false;
+ }
+
+ return true;
+}
+
/* Check that an expression is real or complex. */
static bool
@@ -1404,10 +1460,10 @@ gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_e
bool
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
{
- if (!type_check (i, 0, BT_INTEGER))
+ if (!int_or_boz_check (i, 0))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ if (!int_or_boz_check (j, 1))
return false;
return true;
@@ -1523,12 +1579,12 @@ gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, g
bool
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
- if (!numeric_check (x, 0))
+ if (x->ts.type != BT_BOZ && !numeric_or_boz_check (x, 0))
return false;
if (y != NULL)
{
- if (!numeric_check (y, 1))
+ if (y->ts.type != BT_BOZ && !numeric_or_boz_check (y, 1))
return false;
if (x->ts.type == BT_COMPLEX)
@@ -1859,13 +1915,27 @@ gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image,
bool
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
- if (!int_or_real_check (x, 0))
- return false;
+ if (x->ts.type != BT_BOZ && x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER or "
+ "REAL or boz-literal-constant",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &x->where);
+ return false;
+ }
+
if (!scalar_check (x, 0))
return false;
- if (!int_or_real_check (y, 1))
- return false;
+ if (y->ts.type != BT_BOZ && y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER or "
+ "REAL or boz-literal-constant",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &y->where);
+ return false;
+ }
+
if (!scalar_check (y, 1))
return false;
@@ -1980,12 +2050,12 @@ bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
bool
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
{
- if (!numeric_check (x, 0))
+ if (x->ts.type != BT_BOZ && !numeric_or_boz_check (x, 0))
return false;
if (y != NULL)
{
- if (!numeric_check (y, 1))
+ if (y->ts.type != BT_BOZ && !numeric_or_boz_check (y, 1))
return false;
if (x->ts.type == BT_COMPLEX)
@@ -2014,6 +2084,9 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
bool
gfc_check_dble (gfc_expr *x)
{
+ if (x->ts.type == BT_BOZ)
+ return true;
+
if (!numeric_check (x, 0))
return false;
@@ -2101,42 +2174,84 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
}
+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;
+}
+
+/* Given a BT_BOZ in i, convert to an BT_INTEGER with kind of j. */
+
+void
+gfc_boz2int (gfc_expr *i, gfc_expr *j)
+{
+ char *t;
+ int radix;
+
+ i->ts.type = BT_INTEGER;
+ i->ts.kind = j->ts.kind;
+
+ t = i->boz;
+ radix = 16;
+ if (*t == 'b') radix = 2;
+ if (*t++ == 'o') radix = 8;
+
+ mpz_init (i->value.integer);
+ mpz_set_str (i->value.integer, t, radix);
+}
+
+
bool
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
{
- if (!type_check (i, 0, BT_INTEGER))
+ if (!int_or_boz_check (i, 0))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ if (!int_or_boz_check (j, 1))
return false;
- if (i->is_boz && j->is_boz)
- {
- gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
- "constants", &i->where, &j->where);
- 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 (i->ts.type == BT_BOZ)
+ gfc_boz2int (i, j);
+
+ if (j->ts.type == BT_BOZ)
+ gfc_boz2int (j, i);
+
+ if (!same_type_check (i, 0, j, 1))
return false;
- if (!type_check (shift, 2, BT_INTEGER))
+ if (!int_or_boz_check (shift, 2))
return false;
+ if (shift->ts.type == BT_BOZ)
+ gfc_boz2int (shift, i);
+
+ /* shift shall be nonnegative and less than or equal to BIT_SIZE(I)
+ if I is an integer; otherwise, it shall be less than or equal to
+ BIT_SIZE(J). */
+
if (!nonnegative_check ("SHIFT", shift))
return false;
- if (i->is_boz)
+ if (i->ts.type == BT_BOZ)
{
if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
return false;
- i->ts.kind = j->ts.kind;
}
- else
+ else
{
if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
return false;
- j->ts.kind = i->ts.kind;
}
return true;
@@ -2361,18 +2476,27 @@ gfc_check_i (gfc_expr *i)
bool
-gfc_check_iand (gfc_expr *i, gfc_expr *j)
+gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
{
- if (!type_check (i, 0, BT_INTEGER))
+ if (!int_or_boz_check (i, 0))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ if (!int_or_boz_check (j, 1))
return false;
+ if (!boz_args_check (i, j))
+ return false;
+
+ if (i->ts.type == BT_BOZ)
+ gfc_boz2int (i, j);
+
+ if (j->ts.type == BT_BOZ)
+ gfc_boz2int (j, i);
+
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
- &i->where))
+ gfc_error ("Arguments of %qs have different kind type parameters "
+ "at %L", gfc_current_intrinsic, &i->where);
return false;
}
@@ -2487,26 +2611,6 @@ gfc_check_idnint (gfc_expr *a)
bool
-gfc_check_ieor (gfc_expr *i, gfc_expr *j)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- if (i->ts.kind != j->ts.kind)
- {
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
- &i->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
gfc_expr *kind)
{
@@ -2540,7 +2644,7 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring
bool
gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
- if (!numeric_check (x, 0))
+ if (!numeric_or_boz_check (x, 0))
return false;
if (!kind_check (kind, 1, BT_INTEGER))
@@ -2559,28 +2663,7 @@ gfc_check_intconv (gfc_expr *x)
return true;
}
-
bool
-gfc_check_ior (gfc_expr *i, gfc_expr *j)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- if (i->ts.kind != j->ts.kind)
- {
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
- &i->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
{
if (!type_check (i, 0, BT_INTEGER)
@@ -3358,21 +3441,45 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource,
bool
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
{
- if (!type_check (i, 0, BT_INTEGER))
+ if (!int_or_boz_check (i, 0))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ if (!int_or_boz_check (j, 1))
return false;
- if (!type_check (mask, 2, BT_INTEGER))
+ if (!boz_args_check (i, j))
return false;
- if (!same_type_check (i, 0, j, 1))
+ if (!int_or_boz_check (mask, 2))
return false;
- if (!same_type_check (i, 0, mask, 2))
- return false;
+ if (i->ts.type == BT_BOZ)
+ {
+ gfc_boz2int (i, j);
+ if (mask->ts.type == BT_BOZ)
+ gfc_boz2int (mask, j);
+ else if (!same_type_check (j, 0, mask, 2))
+ return false;
+ }
+ else if (j->ts.type == BT_BOZ)
+ {
+ gfc_boz2int (j, i);
+ if (mask->ts.type == BT_BOZ)
+ gfc_boz2int (mask, i);
+ else if (!same_type_check (i, 0, mask, 2))
+ return false;
+ }
+ else
+ {
+ if (!same_type_check (i, 0, j, 1))
+ return false;
+ if (mask->ts.type == BT_BOZ)
+ gfc_boz2int (mask, i);
+ else if (!same_type_check (i, 0, mask, 2))
+ return false;
+ }
+
return true;
}
@@ -3774,7 +3881,10 @@ gfc_check_rank (gfc_expr *a)
bool
gfc_check_real (gfc_expr *a, gfc_expr *kind)
{
- if (!numeric_check (a, 0))
+ if (a->ts.type == BT_BOZ)
+ return true;
+
+ if (!numeric_or_boz_check (a, 0))
return false;
if (!kind_check (kind, 1, BT_REAL))
@@ -6430,21 +6540,34 @@ 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)
+ if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL
+ && i->ts.type != BT_BOZ)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
+ "or LOGICAL or a boz-literal-constant",
+ gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
}
- if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
+ if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL
+ && j->ts.type != BT_BOZ)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
+ "or LOGICAL or a boz-literal-constant",
+ gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
}
+
+ if (!boz_args_check (i, j))
+ return false;
+
+ if (i->ts.type == BT_BOZ)
+ gfc_boz2int (i, j);
+
+ if (j->ts.type == BT_BOZ)
+ gfc_boz2int (j, i);
if (i->ts.type != j->ts.type)
{
Index: gcc/fortran/data.c
===================================================================
--- gcc/fortran/data.c (revision 253236)
+++ gcc/fortran/data.c (working copy)
@@ -508,9 +508,33 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rva
return false;
}
- expr = gfc_copy_expr (rvalue);
- if (!gfc_compare_types (&lvalue->ts, &expr->ts))
- gfc_convert_type (expr, &lvalue->ts, 0);
+ if (rvalue->ts.type == BT_BOZ)
+ {
+ char *t;
+ int radix;
+
+ if (lvalue->ts.type != BT_INTEGER)
+ {
+ gfc_error ("data-stmt-object at %L must be of type INTEGER",
+ &lvalue->where);
+ return false;
+ }
+
+ t = rvalue->boz;
+ radix = 16;
+ if (*t == 'b') radix = 2;
+ if (*t++ == 'o') radix = 8;
+
+ expr = gfc_get_constant_expr (BT_INTEGER, lvalue->ts.kind,
+ &lvalue->where);
+ mpz_set_str (expr->value.integer, t, radix);
+ }
+ else
+ {
+ expr = gfc_copy_expr (rvalue);
+ if (!gfc_compare_types (&lvalue->ts, &expr->ts))
+ gfc_convert_type (expr, &lvalue->ts, 0);
+ }
}
if (last_con == NULL)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 253236)
+++ gcc/fortran/expr.c (working copy)
@@ -50,6 +50,7 @@ gfc_get_expr (void)
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
+ e->boz = NULL;
return e;
}
@@ -333,6 +334,7 @@ gfc_copy_expr (gfc_expr *p)
}
break;
+ case BT_BOZ:
case BT_HOLLERITH:
case BT_LOGICAL:
case_bt_struct:
@@ -453,6 +455,10 @@ free_expr0 (gfc_expr *e)
mpc_clear (e->value.complex);
break;
+ case BT_BOZ:
+ free (e->boz);
+ break;
+
default:
break;
}
@@ -3282,45 +3288,55 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue,
&& !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 (lvalue->ts.type != BT_INTEGER)
{
- 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;
+ 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;
+ }
}
+ else
+ {
+ gfc_boz2int(rvalue, lvalue);
+ return true;
+ }
}
if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
@@ -3344,6 +3360,9 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue,
return true;
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
+ return true;
+
+ if (lvalue->ts.type == BT_INTEGER && rvalue->ts.type == BT_BOZ)
return true;
gfc_error ("Incompatible types in DATA statement at %L; attempted "
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 253236)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2113,10 +2113,12 @@ 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;
+ /* The BOZ string with either a 'b', 'o', and 'z' prefix. */
+ char *boz;
+
/* Sometimes, when an error has been emitted, it is necessary to prevent
it from recurring. */
unsigned int error : 1;
@@ -3360,6 +3362,7 @@ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *);
/* check.c */
+void gfc_boz2int (gfc_expr *, gfc_expr *);
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*);
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 253236)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -1970,8 +1970,9 @@ add_functions (void)
make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
- add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
- gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
+ add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_F95,
+ gfc_check_iand_ieor_ior, gfc_simplify_iand, gfc_resolve_iand,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
if (flag_dec_intrinsic_ints)
@@ -2059,8 +2060,9 @@ add_functions (void)
make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
- add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
- gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
+ add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_F95,
+ gfc_check_iand_ieor_ior, gfc_simplify_ieor, gfc_resolve_ieor,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
if (flag_dec_intrinsic_ints)
@@ -2137,8 +2139,9 @@ add_functions (void)
make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
- add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
- gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
+ add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_F95,
+ gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
if (flag_dec_intrinsic_ints)
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 253236)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -87,17 +87,15 @@ bool gfc_check_hostnm (gfc_expr *);
bool gfc_check_huge (gfc_expr *);
bool gfc_check_hypot (gfc_expr *, gfc_expr *);
bool gfc_check_i (gfc_expr *);
-bool gfc_check_iand (gfc_expr *, gfc_expr *);
+bool gfc_check_iand_ieor_ior (gfc_expr *, gfc_expr *);
bool gfc_check_and (gfc_expr *, gfc_expr *);
bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
bool gfc_check_idnint (gfc_expr *);
-bool gfc_check_ieor (gfc_expr *, gfc_expr *);
bool gfc_check_image_status (gfc_expr *, gfc_expr *);
bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_int (gfc_expr *, gfc_expr *);
bool gfc_check_intconv (gfc_expr *);
-bool gfc_check_ior (gfc_expr *, gfc_expr *);
bool gfc_check_irand (gfc_expr *);
bool gfc_check_isatty (gfc_expr *);
bool gfc_check_isnan (gfc_expr *);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 253236)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -1142,15 +1142,20 @@ Function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
-type or a scalar @code{LOGICAL} type.
-@item @var{J} @tab The type shall be the same as the type of @var{I}.
+type or a scalar @code{LOGICAL} type or a boz-literal-constant.
+@item @var{J} @tab The type shall be the same as the type of @var{I} or
+a boz-literal-constant. @var{I} and @var{J} shall not both be
+boz-literal-constants. If either @var{I} or @var{J} is a
+boz-literal-constant, then the other argument must be a scalar @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return type is either a scalar @code{INTEGER} or a scalar
@code{LOGICAL}. If the kind type parameters differ, then the
smaller kind type is implicitly converted to larger kind, and the
-return has the larger kind.
+return has the larger kind. A boz-literal-constant is
+converted to an @code{INTEGER} with the kind type parameter of
+the other argument as-if a call to @ref{INT} occurred.
@item @emph{Example}:
@smallexample
@@ -7461,16 +7466,17 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab The type shall be @code{INTEGER}.
-@item @var{J} @tab The type shall be @code{INTEGER}, of the same
-kind as @var{I}. (As a GNU extension, different kinds are also
-permitted.)
+@item @var{I} @tab The type shall be @code{INTEGER} or a boz-literal-constant.
+@item @var{J} @tab The type shall be @code{INTEGER} with the same
+kind type parameter as @var{I} or a boz-literal-constant.
+@var{I} and @var{J} shall not both be boz-literal-constants.
@end multitable
@item @emph{Return value}:
-The return type is @code{INTEGER}, of the same kind as the
-arguments. (If the argument kinds differ, it is of the same kind as
-the larger argument.)
+The return type is @code{INTEGER} with the kind type parameter of the
+arguments.
+A boz-literal-constant is converted to an @code{INTEGER} with the kind
+type parameter of the other argument as-if a call to @ref{INT} occurred.
@item @emph{Example}:
@smallexample
@@ -7911,16 +7917,17 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab The type shall be @code{INTEGER}.
-@item @var{J} @tab The type shall be @code{INTEGER}, of the same
-kind as @var{I}. (As a GNU extension, different kinds are also
-permitted.)
+@item @var{I} @tab The type shall be @code{INTEGER} or a boz-literal-constant.
+@item @var{J} @tab The type shall be @code{INTEGER} with the same
+kind type parameter as @var{I} or a boz-literal-constant.
+@var{I} and @var{J} shall not both be boz-literal-constants.
@end multitable
@item @emph{Return value}:
-The return type is @code{INTEGER}, of the same kind as the
-arguments. (If the argument kinds differ, it is of the same kind as
-the larger argument.)
+The return type is @code{INTEGER} with the kind type parameter of the
+arguments.
+A boz-literal-constant is converted to an @code{INTEGER} with the kind
+type parameter of the other argument as-if a call to @ref{INT} occurred.
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@@ -8229,16 +8236,17 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab The type shall be @code{INTEGER}.
-@item @var{J} @tab The type shall be @code{INTEGER}, of the same
-kind as @var{I}. (As a GNU extension, different kinds are also
-permitted.)
+@item @var{I} @tab The type shall be @code{INTEGER} or a boz-literal-constant.
+@item @var{J} @tab The type shall be @code{INTEGER} with the same
+kind type parameter as @var{I} or a boz-literal-constant.
+@var{I} and @var{J} shall not both be boz-literal-constants.
@end multitable
@item @emph{Return value}:
-The return type is @code{INTEGER}, of the same kind as the
-arguments. (If the argument kinds differ, it is of the same kind as
-the larger argument.)
+The return type is @code{INTEGER} with the kind type parameter of the
+arguments.
+A boz-literal-constant is converted to an @code{INTEGER} with the kind
+type parameter of the other argument as-if a call to @ref{INT} occurred.
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@@ -10225,11 +10233,12 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab Shall be of type @code{INTEGER}.
-@item @var{J} @tab Shall be of type @code{INTEGER} and of the same
-kind as @var{I}.
-@item @var{MASK} @tab Shall be of type @code{INTEGER} and of the same
-kind as @var{I}.
+@item @var{I} @tab Shall be of type @code{INTEGER} or a boz-literal-constant.
+@item @var{J} @tab Shall be of type @code{INTEGER} with the same
+kind type parameter as @var{I} or a boz-literal-constant.
+@var{I} and @var{J} shall not both be boz-literal-constants.
+@item @var{MASK} @tab Shall be of type @code{INTEGER} or a boz-literal-constant
+and of the same kind as @var{I}.
@end multitable
@item @emph{Return value}:
@@ -11046,15 +11055,20 @@ Function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
-type or a scalar @code{LOGICAL} type.
-@item @var{J} @tab The type shall be the same as the type of @var{J}.
+type or a scalar @code{LOGICAL} type or a boz-literal-constant.
+@item @var{J} @tab The type shall be the same as the type of @var{I} or
+a boz-literal-constant. @var{I} and @var{J} shall not both be
+boz-literal-constants. If either @var{I} and @var{J} is a
+boz-literal-constant, then the other argument must be a scalar @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return type is either a scalar @code{INTEGER} or a scalar
@code{LOGICAL}. If the kind type parameters differ, then the
smaller kind type is implicitly converted to larger kind, and the
-return has the larger kind.
+return has the larger kind. A boz-literal-constant is
+converted to an @code{INTEGER} with the kind type parameter of
+the other argument as-if a call to @ref{INT} occurred.
@item @emph{Example}:
@smallexample
@@ -14506,16 +14520,21 @@ Function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
-type or a scalar @code{LOGICAL} type.
-@item @var{J} @tab The type shall be the same as the type of @var{I}.
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
+type or a scalar @code{LOGICAL} type or a boz-literal-constant.
+@item @var{J} @tab The type shall be the same as the type of @var{I} or
+a boz-literal-constant. @var{I} and @var{J} shall not both be
+boz-literal-constants. If either @var{I} and @var{J} is a
+boz-literal-constant, then the other argument must be a scalar @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return type is either a scalar @code{INTEGER} or a scalar
@code{LOGICAL}. If the kind type parameters differ, then the
smaller kind type is implicitly converted to larger kind, and the
-return has the larger kind.
+return has the larger kind. A boz-literal-constant is
+converted to an @code{INTEGER} with the kind type parameter of
+the other argument as-if a call to @ref{INT} occurred.
@item @emph{Example}:
@smallexample
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c (revision 253236)
+++ gcc/fortran/iresolve.c (working copy)
@@ -1222,19 +1222,8 @@ gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_ex
void
-gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED)
{
- /* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
- kinds to match. */
- if (i->ts.kind != j->ts.kind)
- {
- if (i->ts.kind == gfc_kind_max (i, j))
- gfc_convert_type (j, &i->ts, 2);
- else
- gfc_convert_type (i, &j->ts, 2);
- }
-
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
}
@@ -1313,38 +1302,16 @@ gfc_resolve_ierrno (gfc_expr *f)
void
-gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED)
{
- /* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
- kinds to match. */
- if (i->ts.kind != j->ts.kind)
- {
- if (i->ts.kind == gfc_kind_max (i, j))
- gfc_convert_type (j, &i->ts, 2);
- else
- gfc_convert_type (i, &j->ts, 2);
- }
-
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
}
void
-gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
+gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED)
{
- /* If the kind of i and j are different, then g77 cross-promoted the
- kinds to the largest value. The Fortran 95 standard requires the
- kinds to match. */
- if (i->ts.kind != j->ts.kind)
- {
- if (i->ts.kind == gfc_kind_max (i, j))
- gfc_convert_type (j, &i->ts, 2);
- else
- gfc_convert_type (i, &j->ts, 2);
- }
-
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
}
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 253236)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -159,12 +159,12 @@ typedef enum
#define GFC_DTYPE_TYPE_MASK 0x38
#define GFC_DTYPE_SIZE_SHIFT 6
-/* Basic types. BT_VOID is used by ISO C Binding so funcs like c_f_pointer
+/* Basic types. BT_VOID is used by ISO C Binding so functions like c_f_pointer
can take any arg with the pointer attribute as a param. These are also
used in the run-time library for IO. */
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;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 253236)
+++ gcc/fortran/primary.c (working copy)
@@ -328,16 +328,16 @@ cleanup:
}
-/* Match a binary, octal or hexadecimal constant that can be found in
- a DATA statement. The standard permits b'010...', o'73...', and
- z'a1...' where b, o, and z can be capital letters. This function
- also accepts postfixed forms of the constants: '01...'b, '73...'o,
- and 'a1...'z. An additional extension is the use of x for z. */
+/* Match a binary, octal or hexadecimal constant. The standard permits
+ b'010...', o'73...', and z'a1...' where b, o, and z can be capital
+ letters. This function also accepts postfixed forms of the constants:
+ '01...'b, '73...'o, and 'a1...'z. An additional extension is the use
+ of x for z. */
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;
@@ -443,18 +443,16 @@ match_boz_constant (gfc_expr **result)
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;
- }
+ /* Save the BOZ with an appropriate prefix, e.g., b1001011. */
+ e = gfc_get_constant_expr (BT_BOZ, -1, &gfc_current_locus);
+ e->boz = XCNEWVEC (char, length + 2);
+ if (radix == 2)
+ strcpy (e->boz, "b");
+ else if (radix == 8)
+ strcpy (e->boz, "o");
+ else
+ strcpy (e->boz, "z");
+ strcat (e->boz, buffer);
if (!gfc_in_match_data ()
&& (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 253236)
+++ gcc/fortran/resolve.c (working copy)
@@ -3776,6 +3776,31 @@ resolve_operator (gfc_expr *e)
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_POWER:
+
+ if (op1->ts.type == BT_BOZ && op2->ts.type == BT_BOZ)
+ {
+ gfc_error ("Operands at %L and %L of intrinsic operator %qs cannot "
+ "both be boz-literal-constants", &op1->where, &op2->where,
+ gfc_op2string (e->value.op.op));
+ return false;
+ }
+
+ if (op1->ts.type == BT_BOZ)
+ {
+ if (op2->ts.type == BT_INTEGER)
+ gfc_boz2int (op1, op2);
+ else
+ gfc_convert_boz (op1, &op2->ts);
+ }
+
+ if (op2->ts.type == BT_BOZ)
+ {
+ if (op1->ts.type == BT_INTEGER)
+ gfc_boz2int (op2, op1);
+ else
+ gfc_convert_boz (op2, &op1->ts);
+ }
+
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e, 1);
@@ -3886,6 +3911,30 @@ resolve_operator (gfc_expr *e)
break;
}
+ if (op1->ts.type == BT_BOZ && op2->ts.type == BT_BOZ)
+ {
+ gfc_error ("Operands of comparison operator %qs at %L cannot both be "
+ "boz-literal-constants", gfc_op2string (e->value.op.op),
+ &op2->where);
+ return false;
+ }
+
+ if (op1->ts.type == BT_BOZ)
+ {
+ if (op2->ts.type == BT_INTEGER)
+ gfc_boz2int (op1, op2);
+ else
+ gfc_convert_boz (op1, &op2->ts);
+ }
+
+ if (op2->ts.type == BT_BOZ)
+ {
+ if (op1->ts.type == BT_INTEGER)
+ gfc_boz2int (op2, op1);
+ else
+ gfc_convert_boz (op2, &op1->ts);
+ }
+
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e, 1);
@@ -7387,8 +7436,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bo
if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
&& !UNLIMITED_POLY (e))
{
- int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
- code->ext.alloc.ts.u.cl->length);
+ int cmp;
+
+ if (!e->ts.u.cl->length)
+ goto failure;
+
+ cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
+ code->ext.alloc.ts.u.cl->length);
+
if (cmp == 1 || cmp == -1 || cmp == -3)
{
gfc_error ("Allocating %s at %L with type-spec requires the same "
@@ -10059,14 +10114,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace
lhs = code->expr1;
rhs = code->expr2;
- if (rhs->is_boz
+ if (rhs->ts.type == BT_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 && lhs->ts.type != BT_INTEGER)
{
int rc;
if (warn_surprising)
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 253236)
+++ gcc/fortran/simplify.c (working copy)
@@ -212,7 +212,7 @@ gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
static gfc_expr *
convert_boz (gfc_expr *x, int kind)
{
- if (x && x->ts.type == BT_INTEGER && x->is_boz)
+ if (x && x->ts.type == BT_BOZ)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
@@ -1614,14 +1614,21 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_exp
{
gfc_expr *result;
- if (convert_boz (x, kind) == &gfc_bad_expr)
- return &gfc_bad_expr;
+ /* If x is a BOZ at this point, then convert it. */
+ if (x->expr_type == EXPR_CONSTANT)
+ {
+ 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 y is a BOZ at this point, then convert it. */
+ if (y && y->expr_type == EXPR_CONSTANT)
+ {
+ 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))
+ if (x->expr_type != EXPR_CONSTANT || (y && y->expr_type != EXPR_CONSTANT))
return NULL;
result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
@@ -1685,7 +1692,21 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
{
int kind;
- if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
+ if (x->ts.type == BT_BOZ)
+ {
+ if (y->ts.type == BT_BOZ || y->ts.type == BT_INTEGER)
+ kind = gfc_default_complex_kind;
+ else
+ kind = y->ts.kind;
+ }
+ else if (y->ts.type == BT_BOZ)
+ {
+ if (x->ts.type == BT_BOZ || x->ts.type == BT_INTEGER)
+ kind = gfc_default_complex_kind;
+ else
+ kind = x->ts.kind;
+ }
+ else if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
kind = gfc_default_complex_kind;
else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
kind = x->ts.kind;
@@ -2504,7 +2525,7 @@ gfc_simplify_float (gfc_expr *a)
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- if (a->is_boz)
+ if (a->ts.type == BT_BOZ)
{
if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
return &gfc_bad_expr;
@@ -3151,6 +3172,19 @@ simplify_intconv (gfc_expr *e, int kind, const char *n
if (e->expr_type != EXPR_CONSTANT)
return NULL;
+
+ if (e->ts.type == BT_BOZ)
+ {
+ char *t;
+ int radix;
+ t = e->boz;
+ radix = 16;
+ if (*t == 'b') radix = 2;
+ if (*t++ == 'o') radix = 8;
+ e->ts.type = BT_INTEGER;
+ mpz_init (e->value.integer);
+ mpz_set_str (e->value.integer, t, radix);
+ }
result = gfc_convert_constant (e, BT_INTEGER, kind);
if (result == &gfc_bad_expr)
Index: gcc/fortran/target-memory.c
===================================================================
--- gcc/fortran/target-memory.c (revision 253236)
+++ gcc/fortran/target-memory.c (working copy)
@@ -735,7 +735,27 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e,
return len;
}
+/* boz2int implements the old semantics of converting a boz to an
+ integer with the largest kind value. This is a kludge until one
+ determines if gfc_convert_boz can use e->boz directly. */
+static void
+boz2int (gfc_expr *i)
+{
+ char *t;
+ int radix;
+
+ t = i->boz;
+ radix = 16;
+ if (*t == 'b') radix = 2;
+ if (*t++ == 'o') radix = 8;
+
+ i->ts.kind = gfc_max_integer_kind;
+ mpz_init (i->value.integer);
+ mpz_set_str (i->value.integer, t, radix);
+}
+
+
/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
When successful, no BOZ or nothing to do, true is returned. */
@@ -746,12 +766,11 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
int index;
unsigned char *buffer;
- if (!expr->is_boz)
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+
+ if (expr->ts.type != BT_BOZ)
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)
{
@@ -766,7 +785,9 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
else
return true;
+
/* Convert BOZ to the smallest possible integer kind. */
+ boz2int (expr);
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
if (boz_bit_size > ts_bit_size)
@@ -798,7 +819,6 @@ gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
gfc_interpret_complex (ts->kind, buffer, buffer_size,
expr->value.complex);
}
- expr->is_boz = 0;
expr->ts.type = ts->type;
expr->ts.kind = ts->kind;
Index: gcc/testsuite/gfortran.dg/achar_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/achar_5.f90 (revision 253236)
+++ gcc/testsuite/gfortran.dg/achar_5.f90 (working copy)
@@ -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
Index: gcc/testsuite/gfortran.dg/boz_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/boz_4.f90 (revision 253236)
+++ gcc/testsuite/gfortran.dg/boz_4.f90 (nonexistent)
@@ -1,29 +0,0 @@
-! { dg-do compile }
-! Test that the conversion of a BOZ constant that is too large for the
-! integer variable is caught by the compiler.
-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(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" }
-
-end program boz
Index: gcc/testsuite/gfortran.dg/graphite/id-26.f03
===================================================================
--- gcc/testsuite/gfortran.dg/graphite/id-26.f03 (revision 253236)
+++ gcc/testsuite/gfortran.dg/graphite/id-26.f03 (working copy)
@@ -51,11 +51,11 @@
! Attempt to create 64-byte aligned allocatable
do i = 1, 64
allocate (c(1023 + i))
- if (iand (loc (c(1)), 63) == 0) exit
+ if (iand(int(loc(c(1)), 8), 63_8) == 0) exit
deallocate (c)
allocate (b(i)%a(1023 + i))
allocate (c(1023 + i))
- if (iand (loc (c(1)), 63) == 0) exit
+ if (iand(int(loc(c(1)), 8), 63_8) == 0) exit
deallocate (c)
end do
if (allocated (c)) then
Index: gcc/testsuite/gfortran.dg/pr81509_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr81509_1.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr81509_1.f90 (working copy)
@@ -0,0 +1,12 @@
+! { dg-do run }
+! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81509
+program foo
+logical :: a = .false.
+integer :: i = 42
+integer(8) :: k = 42
+if (kind(ieor(z'ade',i)) /= 4) call abort
+if (kind(ior(i,z'1111')) /= 4) call abort
+if (kind(ior(1_8,k)) /= 8) call abort
+if (kind(iand(k,b'1111')) /= 8) call abort
+end program foo
+
Index: gcc/testsuite/gfortran.dg/pr81509_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr81509_2.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr81509_2.f90 (working copy)
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81509
+!
+program foo
+logical :: a = .false.
+integer :: i = 42
+integer(8) :: k
+k = iand(z'aaaa', z'1234') ! { dg-error "cannot both be BOZ literal" }
+k = and(z'aaaa', z'1234') ! { dg-error "cannot both be BOZ literal" }
+k = and(1, z'1234')
+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" }
+end program foo
+
Index: gcc/testsuite/gfortran.dg/unf_io_convert_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unf_io_convert_2.f90 (revision 253236)
+++ gcc/testsuite/gfortran.dg/unf_io_convert_2.f90 (working copy)
@@ -6,6 +6,11 @@ program main
integer(kind=1) :: b(8)
integer(kind=8) :: j
+ integer(1), parameter :: b1 = z'11', b2 = z'22', b3 = z'33', b4 = z'44', b5 = z'55', &
+ & b6 = z'66', b7 = z'77', b8 = z'00' ! { dg-warning "BOZ literal" }
+
+ integer(4), parameter :: i1 = z'11223344', i2 = z'55667700' ! { dg-warning "BOZ literal" }
+
c = (3.14, 2.71)
open (10, form="unformatted",convert="swap") ! { dg-warning "Extension: CONVERT" }
write (10) c
@@ -15,11 +20,11 @@ program main
close(10,status="delete")
open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" }
- i = (/ Z'11223344', Z'55667700' /)
+ i = (/ i1, i2 /)
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 /= (/ b1, b2, b3, b4, b5, b6, b7, b8 /))) &
call abort
backspace 10
read (10) j
@@ -30,7 +35,7 @@ program main
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 /= (/ b4, b3, b2, b1, b8, b7, b6, b5 /))) &
call abort
backspace 10
read (10) j