Commit 00a4618b by Tobias Burnus Committed by Tobias Burnus

re PR fortran/34342 (BOZ extensions not diagnosed as such with -std=f95)

2007-12-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34342
        PR fortran/34345
        PR fortran/18026
        PR fortran/29471

        * gfortran.texi (BOZ literal constants): Improve documentation
        and adapt for BOZ changes.
        * Make-lang.ini (resolve.o): Add target-memory.h dependency.
        * gfortran.h (gfc_expr): Add is_boz flag.
        * expr.c: Include target-memory.h.
        (gfc_check_assign): Support transferring BOZ for real/cmlx.
        * resolve.c: Include target-memory.h
        (resolve_ordinary_assign): Support transferring BOZ for real/cmlx.
        * target-memory.c (gfc_convert_boz): New function.
        * target-memory.c (gfc_convert_boz): Add prototype.
        * primary.c (match_boz_constant): Set is_boz, enable F95 error
        also without -pedantic, and allow for Fortran 2003 BOZ.
        (match_real_constant): Fix comment.
        * simplify.c
        * (simplify_cmplx,gfc_simplify_dble,gfc_simplify_float,
        gfc_simplify_real): Support Fortran 2003 BOZ.

2007-12-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34342
        PR fortran/34345
        PR fortran/18026
        PR fortran/29471

        * gfortran.dg/boz_8.f90: New.
        * gfortran.dg/boz_9.f90: New.
        * gfortran.dg/boz_10.f90: New.
        * gfortran.dg/boz_7.f90: Update dg-warning.
        * gfortran.dg/pr16433.f: Add dg-error.
        * gfortan.dg/ibits.f90: Update dg-warning.
        * gfortran.dg/unf_io_convert_1.f90: Update/delete dg-warning.
        * gfortran.dg/unf_io_convert_2.f90: Ditto.

From-SVN: r130713
parent 1b271c9b
2007-12-08 Tobias Burnus <burnus@net-b.de>
PR fortran/34342
PR fortran/34345
PR fortran/18026
PR fortran/29471
* gfortran.texi (BOZ literal constants): Improve documentation
and adapt for BOZ changes.
* Make-lang.ini (resolve.o): Add target-memory.h dependency.
* gfortran.h (gfc_expr): Add is_boz flag.
* expr.c: Include target-memory.h.
(gfc_check_assign): Support transferring BOZ for real/cmlx.
* resolve.c: Include target-memory.h
(resolve_ordinary_assign): Support transferring BOZ for real/cmlx.
* target-memory.c (gfc_convert_boz): New function.
* target-memory.c (gfc_convert_boz): Add prototype.
* primary.c (match_boz_constant): Set is_boz, enable F95 error
also without -pedantic, and allow for Fortran 2003 BOZ.
(match_real_constant): Fix comment.
* simplify.c (simplify_cmplx,gfc_simplify_dble,gfc_simplify_float,
gfc_simplify_real): Support Fortran 2003 BOZ.
2007-12-08 Jakub Jelinek <jakub@redhat.com> 2007-12-08 Jakub Jelinek <jakub@redhat.com>
PR fortran/34359 PR fortran/34359
......
...@@ -324,6 +324,6 @@ fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ ...@@ -324,6 +324,6 @@ fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-trans-intrinsic.h gt-fortran-trans-intrinsic.h
fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H) fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H)
fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/target-memory.h
fortran/data.o: fortran/data.h fortran/data.o: fortran/data.h
fortran/options.o: $(PARAMS_H) $(TARGET_H) fortran/options.o: $(PARAMS_H) $(TARGET_H)
...@@ -24,6 +24,7 @@ along with GCC; see the file COPYING3. If not see ...@@ -24,6 +24,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h" #include "gfortran.h"
#include "arith.h" #include "arith.h"
#include "match.h" #include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
/* Get a new expr node. */ /* Get a new expr node. */
...@@ -2723,6 +2724,29 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) ...@@ -2723,6 +2724,29 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
&& gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS) && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
return FAILURE; return FAILURE;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
"initialize non-integer variable '%s'",
&rvalue->where, lvalue->symtree->n.sym->name)
== FAILURE)
return FAILURE;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&rvalue->where) == FAILURE)
return FAILURE;
/* Handle the case of a BOZ literal on the RHS. */
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
{
if (gfc_option.warn_surprising)
gfc_warning ("BOZ literal at %L is bitwise transferred "
"non-integer symbol '%s'", &rvalue->where,
lvalue->symtree->n.sym->name);
gfc_convert_boz (rvalue, &lvalue->ts);
}
if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return SUCCESS; return SUCCESS;
......
...@@ -1430,7 +1430,7 @@ typedef struct gfc_expr ...@@ -1430,7 +1430,7 @@ typedef struct gfc_expr
/* True if the expression is a call to a function that returns an array, /* True if the expression is a call to a function that returns an array,
and if we have decided not to allocate temporary data for that array. */ and if we have decided not to allocate temporary data for that array. */
unsigned int inline_noncopying_intrinsic : 1; unsigned int inline_noncopying_intrinsic : 1, is_boz : 1;
/* Used to quickly find a given constructor by its offset. */ /* Used to quickly find a given constructor by its offset. */
splay_tree con_by_offset; splay_tree con_by_offset;
......
...@@ -862,6 +862,9 @@ Renaming of operators in the @code{USE} statement. ...@@ -862,6 +862,9 @@ Renaming of operators in the @code{USE} statement.
@cindex ISO C Bindings @cindex ISO C Bindings
Interoperability with C (ISO C Bindings) Interoperability with C (ISO C Bindings)
@item
BOZ as argument of INT, REAL, DBLE and CMPLX.
@end itemize @end itemize
...@@ -1084,26 +1087,45 @@ of the @code{READ} statement, and the output item lists of the ...@@ -1084,26 +1087,45 @@ of the @code{READ} statement, and the output item lists of the
@section BOZ literal constants @section BOZ literal constants
@cindex BOZ literal constants @cindex BOZ literal constants
Besides decimal constants, Fortran also supports binary (@code{b}),
octal (@code{o}) and hexadecimal (@code{z}) integer constants. The
syntax is: @samp{prefix quote digits quote}, were the prefix is
either @code{b}, @code{o} or @code{z}, quote is either @code{'} or
@code{"} and the digits are for binary @code{0} or @code{1}, for
octal between @code{0} and @code{7}, and for hexadecimal between
@code{0} and @code{F}. (Example: @code{b'01011101'}.)
Up to Fortran 95, BOZ literals were only allowed to initialize
integer variables in DATA statements. Since Fortran 2003 BOZ literals
are also allowed as argument of @code{REAL}, @code{DBLE}, @code{INT}
and @code{CMPLX}; the result is the same as if the integer BOZ
literal had been converted by @code{TRANSFER} to, respectively,
@code{real}, @code{double precision}, @code{integer} or @code{complex}.
The GNU Fortran intrinsic procedure @code{FLOAT}, @code{DFLOAT},
@code{COMPLEX} and @code{DCMPLX} are treated alike.
As an extension, GNU Fortran allows hexadecimal BOZ literal constants to As an extension, GNU Fortran allows hexadecimal BOZ literal constants to
be specified using the X prefix, in addition to the standard Z prefix. be specified using the @code{X} prefix, in addition to the standard
BOZ literal constants can also be specified by adding a suffix to the @code{Z} prefix. The BOZ literal can also be specified by adding a
string. For example, @code{Z'ABC'} and @code{'ABC'Z} are equivalent. suffix to the string, for example, @code{Z'ABC'} and @code{'ABC'Z} are
equivalent.
The Fortran standard restricts the appearance of a BOZ literal constant
to the @code{DATA} statement, and it is expected to be assigned to an Furthermore, GNU Fortran allows using BOZ literal constants outside
@code{INTEGER} variable. GNU Fortran permits a BOZ literal to appear in DATA statements and the four intrinsic functions allowed by Fortran 2003.
any initialization expression as well as assignment statements. In DATA statements, in direct assignments, where the right-hand side
only contains a BOZ literal constant, and for old-style initializers of
Attempts to use a BOZ literal constant to do a bitwise initialization of the form @code{integer i /o'0173'/}, the constant is transferred
a variable can lead to confusion. A BOZ literal constant is converted as if @code{TRANSFER} had been used. In all other cases, the BOZ literal
to an @code{INTEGER} value with the kind type with the largest decimal constant is converted to an @code{INTEGER} value with
representation, and this value is then converted numerically to the type the largest decimal representation. This value is then converted
and kind of the variable in question. Thus, one should not expect a numerically to the type and kind of the variable in question.
bitwise copy of the BOZ literal constant to be assigned to a @code{REAL} (For instance @code{real :: r = b'0000001' + 1} initializes @code{r}
variable. with @code{2.0}.) As different compilers implement the extension
differently, one should be careful when doing bitwise initialization
Similarly, initializing an @code{INTEGER} variable with a statement such of non-integer variables.
as @code{DATA i/Z'FFFFFFFF'/} will produce an integer overflow rather
Note that initializing an @code{INTEGER} variable with a statement such
as @code{DATA i/Z'FFFFFFFF'/} will give an integer overflow error rather
than the desired result of @math{-1} when @code{i} is a 32-bit integer than the desired result of @math{-1} when @code{i} is a 32-bit integer
on a system that supports 64-bit integers. The @samp{-fno-range-check} on a system that supports 64-bit integers. The @samp{-fno-range-check}
option can be used as a workaround for legacy code that initializes option can be used as a workaround for legacy code that initializes
......
...@@ -349,7 +349,7 @@ match_boz_constant (gfc_expr **result) ...@@ -349,7 +349,7 @@ match_boz_constant (gfc_expr **result)
if (delim != '\'' && delim != '\"') if (delim != '\'' && delim != '\"')
goto backup; goto backup;
if (x_hex && pedantic if (x_hex
&& (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal " && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
"constant at %C uses non-standard syntax") "constant at %C uses non-standard syntax")
== FAILURE)) == FAILURE))
...@@ -415,6 +415,9 @@ match_boz_constant (gfc_expr **result) ...@@ -415,6 +415,9 @@ match_boz_constant (gfc_expr **result)
kind = gfc_max_integer_kind; kind = gfc_max_integer_kind;
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus); 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) if (gfc_range_check (e) != ARITH_OK)
{ {
gfc_error ("Integer too big for integer kind %i at %C", kind); gfc_error ("Integer too big for integer kind %i at %C", kind);
...@@ -422,10 +425,8 @@ match_boz_constant (gfc_expr **result) ...@@ -422,10 +425,8 @@ match_boz_constant (gfc_expr **result)
return MATCH_ERROR; return MATCH_ERROR;
} }
/* FIXME: Fortran 2003 allows BOZ also in REAL(), CMPLX(), INT();
see PR18026 and PR29471. */
if (!gfc_in_match_data () if (!gfc_in_match_data ()
&& (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ used outside a DATA " && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
"statement at %C") "statement at %C")
== FAILURE)) == FAILURE))
return MATCH_ERROR; return MATCH_ERROR;
...@@ -440,7 +441,7 @@ backup: ...@@ -440,7 +441,7 @@ backup:
/* Match a real constant of some sort. Allow a signed constant if signflag /* Match a real constant of some sort. Allow a signed constant if signflag
is nonzero. Allow integer constants if allow_int is true. */ is nonzero. */
static match static match
match_real_constant (gfc_expr **result, int signflag) match_real_constant (gfc_expr **result, int signflag)
......
...@@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see ...@@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see
#include "arith.h" /* For gfc_compare_expr(). */ #include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h" #include "dependency.h"
#include "data.h" #include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
/* Types used in equivalence statements. */ /* Types used in equivalence statements. */
...@@ -5885,7 +5886,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) ...@@ -5885,7 +5886,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
int n; int n;
gfc_ref *ref; gfc_ref *ref;
if (gfc_extend_assign (code, ns) == SUCCESS) if (gfc_extend_assign (code, ns) == SUCCESS)
{ {
lhs = code->ext.actual->expr; lhs = code->ext.actual->expr;
...@@ -5912,6 +5912,24 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) ...@@ -5912,6 +5912,24 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
lhs = code->expr; lhs = code->expr;
rhs = code->expr2; rhs = code->expr2;
if (rhs->is_boz
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&code->loc) == FAILURE)
return false;
/* Handle the case of a BOZ literal on the RHS. */
if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
{
if (gfc_option.warn_surprising)
gfc_warning ("BOZ literal at %L is bitwise transferred "
"non-integer symbol '%s'", &code->loc,
lhs->symtree->n.sym->name);
gfc_convert_boz (rhs, &lhs->ts);
}
if (lhs->ts.type == BT_CHARACTER if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation) && gfc_option.warn_character_truncation)
{ {
......
...@@ -740,7 +740,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) ...@@ -740,7 +740,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
switch (x->ts.type) switch (x->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE); if (!x->is_boz)
mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
break; break;
case BT_REAL: case BT_REAL:
...@@ -761,7 +762,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) ...@@ -761,7 +762,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
switch (y->ts.type) switch (y->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE); if (!y->is_boz)
mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
break; break;
case BT_REAL: case BT_REAL:
...@@ -773,6 +775,25 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) ...@@ -773,6 +775,25 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
} }
} }
/* Handle BOZ. */
if (x->is_boz)
{
gfc_typespec ts;
ts.kind = result->ts.kind;
ts.type = BT_REAL;
gfc_convert_boz (x, &ts);
mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
}
if (y && y->is_boz)
{
gfc_typespec ts;
ts.kind = result->ts.kind;
ts.type = BT_REAL;
gfc_convert_boz (y, &ts);
mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
}
return range_check (result, name); return range_check (result, name);
} }
...@@ -918,7 +939,8 @@ gfc_simplify_dble (gfc_expr *e) ...@@ -918,7 +939,8 @@ gfc_simplify_dble (gfc_expr *e)
switch (e->ts.type) switch (e->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
result = gfc_int2real (e, gfc_default_double_kind); if (!e->is_boz)
result = gfc_int2real (e, gfc_default_double_kind);
break; break;
case BT_REAL: case BT_REAL:
...@@ -933,6 +955,15 @@ gfc_simplify_dble (gfc_expr *e) ...@@ -933,6 +955,15 @@ gfc_simplify_dble (gfc_expr *e)
gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
} }
if (e->ts.type == BT_INTEGER && e->is_boz)
{
gfc_typespec ts;
ts.type = BT_REAL;
ts.kind = gfc_default_double_kind;
result = gfc_copy_expr (e);
gfc_convert_boz (result, &ts);
}
return range_check (result, "DBLE"); return range_check (result, "DBLE");
} }
...@@ -1111,7 +1142,18 @@ gfc_simplify_float (gfc_expr *a) ...@@ -1111,7 +1142,18 @@ gfc_simplify_float (gfc_expr *a)
if (a->expr_type != EXPR_CONSTANT) if (a->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
result = gfc_int2real (a, gfc_default_real_kind); if (a->is_boz)
{
gfc_typespec ts;
ts.type = BT_REAL;
ts.kind = gfc_default_real_kind;
result = gfc_copy_expr (a);
gfc_convert_boz (result, &ts);
}
else
result = gfc_int2real (a, gfc_default_real_kind);
return range_check (result, "FLOAT"); return range_check (result, "FLOAT");
} }
...@@ -2954,7 +2996,8 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) ...@@ -2954,7 +2996,8 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
switch (e->ts.type) switch (e->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
result = gfc_int2real (e, kind); if (!e->is_boz)
result = gfc_int2real (e, kind);
break; break;
case BT_REAL: case BT_REAL:
...@@ -2970,6 +3013,14 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) ...@@ -2970,6 +3013,14 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
/* Not reached */ /* Not reached */
} }
if (e->ts.type == BT_INTEGER && e->is_boz)
{
gfc_typespec ts;
ts.type = BT_REAL;
ts.kind = kind;
result = gfc_copy_expr (e);
gfc_convert_boz (result, &ts);
}
return range_check (result, "REAL"); return range_check (result, "REAL");
} }
......
...@@ -595,3 +595,46 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, ...@@ -595,3 +595,46 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
return len; return len;
} }
void
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
{
size_t buffer_size;
unsigned char *buffer;
if (!expr->is_boz)
return;
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);
else if (ts->type == BT_COMPLEX)
buffer_size = size_complex (ts->kind);
else
return;
buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
buffer = (unsigned char*)alloca (buffer_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
{
mpfr_init (expr->value.complex.r);
mpfr_init (expr->value.complex.i);
gfc_interpret_complex (ts->kind, buffer, buffer_size,
expr->value.complex.r, expr->value.complex.i);
}
expr->is_boz = 0;
expr->ts.type = ts->type;
expr->ts.kind = ts->kind;
}
...@@ -24,6 +24,9 @@ along with GCC; see the file COPYING3. If not see ...@@ -24,6 +24,9 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h" #include "gfortran.h"
/* Convert a BOZ to REAL or COMPLEX. */
void gfc_convert_boz (gfc_expr *, gfc_typespec *);
/* Return the size of an expression in its target representation. */ /* Return the size of an expression in its target representation. */
size_t gfc_target_expr_size (gfc_expr *); size_t gfc_target_expr_size (gfc_expr *);
......
2007-12-06 Tobias Burnus <burnus@net-b.de>
PR fortran/34342
PR fortran/34345
PR fortran/18026
PR fortran/29471
* gfortran.dg/boz_8.f90: New.
* gfortran.dg/boz_9.f90: New.
* gfortran.dg/boz_10.f90: New.
* gfortran.dg/boz_7.f90: Update dg-warning.
* gfortran.dg/pr16433.f: Add dg-error.
* gfortan.dg/ibits.f90: Update dg-warning.
* gfortran.dg/unf_io_convert_1.f90: Update/delete dg-warning.
* gfortran.dg/unf_io_convert_2.f90: Ditto.
2007-12-08 Jakub Jelinek <jakub@redhat.com> 2007-12-08 Jakub Jelinek <jakub@redhat.com>
PR fortran/34359 PR fortran/34359
! { dg-do compile }
! { dg-options "-std=f95" }
!
! PR fortran/34342
!
! Diagnose BOZ literal for non-integer variables in
! a DATA statement. And outside DATA statements.
!
real :: r
integer :: i
r = real(z'FFFF') ! { dg-error "outside a DATA statement" }
i = int(z'4455') ! { dg-error "outside a DATA statement" }
r = z'FFFF' + 1.0 ! { dg-error "outside a DATA statement" }
i = z'4455' + 1 ! { dg-error "outside a DATA statement" }
end
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
! Some BOZ extensions where not diagnosed ! Some BOZ extensions where not diagnosed
! !
integer :: k, m integer :: k, m
integer :: j = z'000abc' ! { dg-error "Extension: BOZ used outside a DATA statement" } integer :: j = z'000abc' ! { dg-error "BOZ used outside a DATA statement" }
data k/x'0003'/ ! { dg-error "uses non-standard syntax" } data k/x'0003'/ ! { dg-error "uses non-standard syntax" }
data m/'0003'z/ ! { dg-error "uses non-standard postfix syntax" } data m/'0003'z/ ! { dg-error "uses non-standard postfix syntax" }
end end
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/34342
!
! Diagnose BOZ literal for non-integer variables in
! a DATA statement. Cf. Fortran 2003, 5.2.5 DATA statement:
! "If a data-stmt-constant is a boz-literal-constant, the
! corresponding variable shall be of type integer."
!
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" }
end
! { dg-do run }
! { dg-options "-fno-range-check" }
!
! PR fortran/34342
!
! Test for Fortran 2003 BOZ.
!
program f2003
implicit none
real,parameter :: r2c = real(int(z'3333'))
real,parameter :: rc = real(z'3333')
double precision,parameter :: dc = dble(Z'3FD34413509F79FF')
complex,parameter :: z1c = cmplx(b'10101',-4.0)
complex,parameter :: z2c = cmplx(5.0, o'01245')
real :: r2 = real(int(z'3333'))
real :: r = real(z'3333')
double precision :: d = dble(Z'3FD34413509F79FF')
complex :: z1 = cmplx(b'10101',-4.0)
complex :: z2 = cmplx(5.0, o'01245')
if (r2c /= 13107.0) stop '1'
if (rc /= 1.83668190E-41) stop '2'
if (dc /= 0.30102999566398120) stop '3'
if (real(z1c) /= 2.94272678E-44 .or. aimag(z1c) /= -4.0) stop '4'
if (real(z2c) /= 5.0 .or. aimag(z2c) /= 9.48679060E-43) stop '5'
if (r2 /= 13107.0) stop '1'
if (r /= 1.83668190E-41) stop '2'
if (d /= 0.30102999566398120) stop '3'
if (real(z1) /= 2.94272678E-44 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 9.48679060E-43) stop '5'
r2 = dble(int(z'3333'))
r = real(z'3333')
d = dble(Z'3FD34413509F79FF')
z1 = cmplx(b'10101',-4.0)
z2 = cmplx(5.0, o'01245')
if (r2 /= 13107.0) stop '1'
if (r /= 1.83668190E-41) stop '2'
if (d /= 0.30102999566398120) stop '3'
if (real(z1) /= 2.94272678E-44 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 9.48679060E-43) stop '5'
call test4()
call test8()
contains
subroutine test4
real,parameter :: r2c = real(int(z'3333', kind=4), kind=4)
real,parameter :: rc = real(z'3333', kind=4)
complex,parameter :: z1c = cmplx(b'10101',-4.0, kind=4)
complex,parameter :: z2c = cmplx(5.0, o'01245', kind=4)
real :: r2 = real(int(z'3333', kind=4), kind=4)
real :: r = real(z'3333', kind=4)
complex :: z1 = cmplx(b'10101',-4.0, kind=4)
complex :: z2 = cmplx(5.0, o'01245', kind=4)
if (r2c /= 13107.0) stop '1'
if (rc /= 1.83668190E-41) stop '2'
if (real(z1c) /= 2.94272678E-44 .or. aimag(z1c) /= -4.0) stop '4'
if (real(z2c) /= 5.0 .or. aimag(z2c) /= 9.48679060E-43) stop '5'
if (r2 /= 13107.0) stop '1'
if (r /= 1.83668190E-41) stop '2'
if (real(z1) /= 2.94272678E-44 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 9.48679060E-43) stop '5'
r2 = real(int(z'3333'), kind=4)
r = real(z'3333', kind=4)
z1 = cmplx(b'10101',-4.0, kind=4)
z2 = cmplx(5.0, o'01245', kind=4)
if (r2 /= 13107.0) stop '1'
if (r /= 1.83668190E-41) stop '2'
if (real(z1) /= 2.94272678E-44 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 9.48679060E-43) stop '5'
end subroutine test4
subroutine test8
real(8),parameter :: r2c = real(int(z'FFFFFF3333', kind=8), kind=8)
real(8),parameter :: rc = real(z'AAAAAAAAAAAAAAAAFFFFFFF3333', kind=8)
complex(8),parameter :: z1c = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
complex(8),parameter :: z2c = cmplx(5.0, o'444444444442222222222233301245', kind=8)
real(8) :: r2 = real(int(z'FFFFFF3333',kind=8),kind=8)
real(8) :: r = real(z'AAAAAAAAAAAAAAAAFFFFFFF3333', kind=8)
complex(8) :: z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
complex(8) :: z2 = cmplx(5.0, o'444444444442222222222233301245', kind=8)
if (r2c /= 1099511575347.0d0) stop '1'
if (rc /= -3.72356884822177915d-103) stop '2'
if (real(z1c) /= 3.05175781249999627d-5 .or. aimag(z1c) /= -4.0) stop '4'
if (real(z2c) /= 5.0 .or. aimag(z2c) /= 3.98227593015308981d41) stop '5'
if (r2 /= 1099511575347.0d0) stop '1'
if (r /= -3.72356884822177915d-103) stop '2'
if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) stop '5'
r2 = real(int(z'FFFFFF3333',kind=8),kind=8)
r = real(z'AAAAAAAAAAAAAAAAFFFFFFF3333', kind=8)
z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8)
z2 = cmplx(5.0, o'444444444442222222222233301245', kind=8)
if (r2 /= 1099511575347.0d0) stop '1'
if (r /= -3.72356884822177915d-103) stop '2'
if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) stop '4'
if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) stop '5'
end subroutine test8
end program f2003
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
! Test that the mask is properly converted to the kind type of j in ibits. ! Test that the mask is properly converted to the kind type of j in ibits.
program ibits_test program ibits_test
implicit none implicit none
integer(8), parameter :: n = z'00000000FFFFFFFF' ! { dg-warning "BOZ used outside a DATA statement" } integer(8), parameter :: n = z'00000000FFFFFFFF' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
integer(8) i,j,k,m integer(8) i,j,k,m
j = 1 j = 1
do i=1,70 do i=1,70
......
! { dg-do compile } ! { dg-do compile }
real x real x
double precision dx double precision dx
data x/x'2ffde'/ ! { dg-warning "exadecimal constant" "Hex constant can't begin with x" } 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" } dx = x ! { dg-bogus "exadecimal constant" "Hex constant where there is none" }
end end
...@@ -18,9 +18,9 @@ program main ...@@ -18,9 +18,9 @@ program main
integer i integer i
character*4 str character*4 str
m(1) = Z'11223344' ! { dg-warning "BOZ used outside a DATA statement" } m(1) = Z'11223344' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
m(2) = Z'55667788' ! { dg-warning "BOZ used outside a DATA statement" } m(2) = Z'55667788' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
n = Z'77AABBCC' ! { dg-warning "BOZ used outside a DATA statement" } n = Z'77AABBCC' ! { dg-warning "BOZ literal at .1. outside a DATA statement" }
str = 'asdf' str = 'asdf'
do i = 1,size do i = 1,size
r(i) = i r(i) = i
...@@ -46,7 +46,7 @@ program main ...@@ -46,7 +46,7 @@ program main
read(9) str read(9) str
! !
! check results ! check results
if (m(1).ne.Z'11223344') then ! { dg-warning "BOZ used outside a DATA statement" } if (m(1).ne.Z'11223344') then
if (debug) then if (debug) then
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1) print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
else else
...@@ -54,7 +54,7 @@ program main ...@@ -54,7 +54,7 @@ program main
endif endif
endif endif
if (m(2).ne.Z'55667788') then ! { dg-warning "BOZ used outside a DATA statement" } if (m(2).ne.Z'55667788') then
if (debug) then if (debug) then
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2) print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
else else
...@@ -62,7 +62,7 @@ program main ...@@ -62,7 +62,7 @@ program main
endif endif
endif endif
if (n.ne.Z'77AABBCC') then ! { dg-warning "BOZ used outside a DATA statement" } if (n.ne.Z'77AABBCC') then
if (debug) then if (debug) then
print '(A,Z8)','n incorrect. n = ',n print '(A,Z8)','n incorrect. n = ',n
else else
......
...@@ -15,26 +15,26 @@ program main ...@@ -15,26 +15,26 @@ program main
close(10,status="delete") close(10,status="delete")
open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" } open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" }
i = (/ Z'11223344', Z'55667700' /) ! { dg-warning "BOZ used outside a DATA statement" } i = (/ Z'11223344', Z'55667700' /)
write (10) i write (10) i
rewind (10) rewind (10)
read (10) b read (10) b
if (any(b /= (/ Z'11', Z'22', Z'33', Z'44', Z'55', Z'66', Z'77', Z'00' /))) & ! { dg-warning "BOZ used outside a DATA statement" } if (any(b /= (/ Z'11', Z'22', Z'33', Z'44', Z'55', Z'66', Z'77', Z'00' /))) &
call abort call abort
backspace 10 backspace 10
read (10) j read (10) j
if (j /= Z'1122334455667700') call abort ! { dg-warning "BOZ used outside a DATA statement" } if (j /= Z'1122334455667700') call abort
close (10, status="delete") close (10, status="delete")
open (10, form="unformatted", convert="little_endian") ! { dg-warning "Extension: CONVERT" } open (10, form="unformatted", convert="little_endian") ! { dg-warning "Extension: CONVERT" }
write (10) i write (10) i
rewind (10) rewind (10)
read (10) b read (10) b
if (any(b /= (/ Z'44', Z'33', Z'22', Z'11', Z'00', Z'77', Z'66', Z'55' /))) & ! { dg-warning "BOZ used outside a DATA statement" } if (any(b /= (/ Z'44', Z'33', Z'22', Z'11', Z'00', Z'77', Z'66', Z'55' /))) &
call abort call abort
backspace 10 backspace 10
read (10) j read (10) j
if (j /= Z'5566770011223344') call abort ! { dg-warning "BOZ used outside a DATA statement" } if (j /= Z'5566770011223344') call abort
close (10, status="delete") close (10, status="delete")
end program main end program main
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment