* gfortran.texi (Internal representation of LOGICAL variables):
Add @ref.
(GFORTRAN_LEGACY_LOGICAL_READ): Document new env variable.
* gfortran.dg/read_logical_1.f90: New.
* gfortran.dg/read_logical_2.f90: New.
* libgfortran.h (options_t): Add legacy_logical_read.
* runtime/environ.c (variable_table): Add entry for
GFORTRAN_LEGACY_LOGICAL_READ.
* io/transfer.c (unformatted_read): If options.legacy_logical_read,
convert bitvalue != 0 to canonical .true. (= 1) for BT_LOGICAL.
gcc/fortran/gfortran.texi | 34 ++++-
gcc/testsuite/gfortran.dg/read_logical_1.f90 | 194 +++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/read_logical_2.f90 | 66 +++++++++
libgfortran/io/transfer.c | 60 ++++++++-
libgfortran/libgfortran.h | 5 +-
libgfortran/runtime/environ.c | 4 +
6 files changed, 355 insertions(+), 8 deletions(-)
@@ -604,15 +604,16 @@ Malformed environment variables are silently ignored.
* GFORTRAN_STDIN_UNIT:: Unit number for standard input
* GFORTRAN_STDOUT_UNIT:: Unit number for standard output
* GFORTRAN_STDERR_UNIT:: Unit number for standard error
-* GFORTRAN_UNBUFFERED_ALL:: Do not buffer I/O for all units.
+* GFORTRAN_UNBUFFERED_ALL:: Do not buffer I/O for all units
* GFORTRAN_UNBUFFERED_PRECONNECTED:: Do not buffer I/O for preconnected units.
* GFORTRAN_SHOW_LOCUS:: Show location for runtime errors
* GFORTRAN_OPTIONAL_PLUS:: Print leading + where permitted
* GFORTRAN_LIST_SEPARATOR:: Separator for list output
* GFORTRAN_CONVERT_UNIT:: Set endianness for unformatted I/O
+* GFORTRAN_LEGACY_LOGICAL_READ:: Nonzero, nonone unformatted reads of logicals
* GFORTRAN_ERROR_BACKTRACE:: Show backtrace on run-time errors
-* GFORTRAN_FORMATTED_BUFFER_SIZE:: Buffer size for formatted files.
-* GFORTRAN_UNFORMATTED_BUFFER_SIZE:: Buffer size for unformatted files.
+* GFORTRAN_FORMATTED_BUFFER_SIZE:: Buffer size for formatted files
+* GFORTRAN_UNFORMATTED_BUFFER_SIZE:: Buffer size for unformatted files
@end menu
@node TMPDIR
@@ -784,6 +785,30 @@ the backtracing, set the variable to @samp{n}, @samp{N}, @samp{0}.
Default is to print a backtrace unless the @option{-fno-backtrace}
compile option was used.
+@node GFORTRAN_LEGACY_LOGICAL_READ
+@section @env{GFORTRAN_LEGACY_LOGICAL_READ}--Nonzero, nonone unformatted reads of logicals
+
+GNU Fortran uses @code{0} and @code{1} as internal representation for
+logical @code{.false.} and @code{.true.}, respectively. However, some other
+compilers use different representations; the most common other representation
+is @code{-1} for @code{.true.}.
+
+The different internal representation affects procedure calls plus writing and
+reading unformatted files. This option only affects the latter. If the first
+character of the @env{GFORTRAN_LEGACY_LOGICAL_READ} environment variable is
+@samp{y}, @samp{Y} or @samp{1}, all nonzero values in unformatted reads of
+logical type are normalized to the internal representation @code{1}, which is
+GNU Fortran's @code{.true.}.
+
+NOTE: Some compilers regard all even integer values as @code{.false.}
+(e.g. 0, 2, -2, etc.) and only as odd values as true; still, those compilers
+default to @code{0} as @code{.false.}, which is, hence, compatible with the
+conversion done by this flag.
+
+See also @ref{Internal representation of LOGICAL variables},
+@ref{Argument passing conventions}, and @ref{Interoperability with C}.
+
+
@node GFORTRAN_FORMATTED_BUFFER_SIZE
@section @env{GFORTRAN_FORMATTED_BUFFER_SIZE}---Set buffer size for formatted I/O
@@ -1276,7 +1301,8 @@ A @code{LOGICAL(KIND=N)} variable is represented as an
values: @code{1} for @code{.TRUE.} and @code{0} for
@code{.FALSE.}. Any other integer value results in undefined behavior.
-See also @ref{Argument passing conventions} and @ref{Interoperability with C}.
+See also @ref{Argument passing conventions}, @ref{Interoperability with C},
+and @ref{GFORTRAN_LEGACY_LOGICAL_READ}.
@node Evaluation of logical expressions
new file mode 100644
@@ -0,0 +1,194 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_LEGACY_LOGICAL_READ "1" }
+!
+! When reading LOGICAL canonilize them to 1 and 0
+!
+! See https://gcc.gnu.org/ml/fortran/2020-01/threads.html#00088
+! and cf. PRs fortran/40539
+!
+implicit none
+integer :: lun
+
+open(newunit=lun, status='scratch', form='unformatted')
+call write_1(lun, .false.)
+call write_2(lun, .false.)
+call write_4(lun, .false.)
+call write_8(lun, .false.)
+rewind(lun)
+call read_1(lun, .false.)
+call read_2(lun, .false.)
+call read_4(lun, .false.)
+call read_8(lun, .false.)
+close(lun)
+
+open(newunit=lun, status='scratch', form='unformatted', asynchronous='yes')
+call write_1(lun, .true.)
+call write_2(lun, .true.)
+call write_4(lun, .true.)
+call write_8(lun, .true.)
+rewind(lun)
+call read_1(lun, .true.)
+call read_2(lun, .true.)
+call read_4(lun, .true.)
+call read_8(lun, .true.)
+close(lun)
+
+contains
+
+subroutine write_1(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer(kind=1), asynchronous :: A, C(10)
+ A = -1
+ !1 2 3 4 5 6 7 8 9, 10
+ C = [0, -2, -1, 3, 5, 0, 1, 0, -6, -1]
+ if (async) then
+ write(lun, asynchronous='yes') A, C
+ wait(lun)
+ else
+ write(lun) A, C
+ endif
+end
+subroutine read_1(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer :: i
+ logical(kind=1), asynchronous :: B, D(10)
+
+ B = .false.
+ D = .false.
+ if (async) then
+ read(lun, asynchronous='yes') B, D
+ wait(lun)
+ else
+ read(lun) B, D
+ endif
+
+ if (B .neqv. .true.) stop 11
+ if (any (D .neqv. [.false., .true., .true., .true., .true., &
+ .false., .true., .false., .true., .true.])) stop 12
+ ! 6 7 8 9 10
+ if (transfer(B, 0_1) /= 1) stop 13
+ if (any ([(transfer(D(i),0_1), i=1,10)] &
+ /= [0, 1, 1, 1, 1, 0, 1, 0, 1, 1])) stop 14
+ !1 2 3 4 5 6 7 8 9 10
+end
+
+subroutine write_2(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer(kind=2), asynchronous :: A, C(10)
+ A = -1
+ !1 2 3 4 5 6 7 8 9, 10
+ C = [0, -2, -1, 3, 5, 0, 1, 0, -6, -1]
+ if (async) then
+ write(lun, asynchronous='yes') A, C
+ wait(lun)
+ else
+ write(lun) A, C
+ endif
+end
+subroutine read_2(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer :: i
+ logical(kind=2), asynchronous :: B, D(10)
+
+ B = .false.
+ D = .false.
+ if (async) then
+ read(lun, asynchronous='yes') B, D
+ wait(lun)
+ else
+ read(lun) B, D
+ endif
+
+ if (B .neqv. .true.) stop 21
+ if (any (D .neqv. [.false., .true., .true., .true., .true., &
+ .false., .true., .false., .true., .true.])) stop 22
+ ! 6 7 8 9 10
+ if (transfer(B, 0_2) /= 1) stop 23
+ if (any ([(transfer(D(i),0_2), i=1,10)] &
+ /= [0, 1, 1, 1, 1, 0, 1, 0, 1, 1])) stop 24
+ !1 2 3 4 5 6 7 8 9 10
+end
+
+subroutine write_4(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer(kind=4), asynchronous :: A, C(10)
+ A = -1
+ !1 2 3 4 5 6 7 8 9, 10
+ C = [0, -2, -1, 3, 5, 0, 1, 0, -6, -1]
+ if (async) then
+ write(lun, asynchronous='yes') A, C
+ wait(lun)
+ else
+ write(lun) A, C
+ endif
+end
+subroutine read_4(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer :: i
+ logical(kind=4), asynchronous :: B, D(10)
+
+ B = .false.
+ D = .false.
+ if (async) then
+ read(lun, asynchronous='yes') B, D
+ wait(lun)
+ else
+ read(lun) B, D
+ endif
+
+ if (B .neqv. .true.) stop 41
+ if (any (D .neqv. [.false., .true., .true., .true., .true., &
+ .false., .true., .false., .true., .true.])) stop 42
+ ! 6 7 8 9 10
+ if (transfer(B, 0_4) /= 1) stop 43
+ if (any ([(transfer(D(i),0_4), i=1,10)] &
+ /= [0, 1, 1, 1, 1, 0, 1, 0, 1, 1])) stop 44
+ !1 2 3 4 5 6 7 8 9 10
+end
+
+subroutine write_8(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer(kind=8), asynchronous :: A, C(10)
+ A = -1
+ !1 2 3 4 5 6 7 8 9, 10
+ C = [0, -2, -1, 3, 5, 0, 1, 0, -6, -1]
+ if (async) then
+ write(lun, asynchronous='yes') A, C
+ wait(lun)
+ else
+ write(lun) A, C
+ endif
+end
+subroutine read_8(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer :: i
+ logical(kind=8), asynchronous :: B, D(10)
+
+ B = .false.
+ D = .false.
+ if (async) then
+ read(lun, asynchronous='yes') B, D
+ wait(lun)
+ else
+ read(lun) B, D
+ endif
+
+ if (B .neqv. .true.) stop 81
+ if (any (D .neqv. [.false., .true., .true., .true., .true., &
+ .false., .true., .false., .true., .true.])) stop 82
+ ! 6 7 8 9 10
+ if (transfer(B, 0_8) /= 1) stop 83
+ if (any ([(transfer(D(i),0_8), i=1,10)] &
+ /= [0, 1, 1, 1, 1, 0, 1, 0, 1, 1])) stop 84
+ !1 2 3 4 5 6 7 8 9 10
+end
+
+end
new file mode 100644
@@ -0,0 +1,66 @@
+! { dg-do run }
+! { dg-require-effective-target fortran_integer_16 }
+! { dg-set-target-env-var GFORTRAN_LEGACY_LOGICAL_READ "1" }
+!
+! When reading LOGICAL canonilize them to 1 and 0
+!
+! See https://gcc.gnu.org/ml/fortran/2020-01/threads.html#00088
+! and cf. PRs fortran/40539
+!
+implicit none
+integer :: lun
+
+open(newunit=lun, status='scratch', form='unformatted')
+call write_16(lun, .false.)
+rewind(lun)
+call read_16(lun, .false.)
+close(lun)
+
+open(newunit=lun, status='scratch', form='unformatted', asynchronous='yes')
+call write_16(lun, .true.)
+rewind(lun)
+call read_16(lun, .true.)
+close(lun)
+
+contains
+
+subroutine write_16(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer(kind=16), asynchronous :: A, C(10)
+ A = -1
+ !1 2 3 4 5 6 7 8 9, 10
+ C = [0, -2, -1, 3, 5, 0, 1, 0, -6, -1]
+ if (async) then
+ write(lun, asynchronous='yes') A, C
+ wait(lun)
+ else
+ write(lun) A, C
+ endif
+end
+subroutine read_16(lun, async)
+ integer, value, intent(in) :: lun
+ logical, value, intent(in) :: async
+ integer :: i
+ logical(kind=16), asynchronous :: B, D(10)
+
+ B = .false.
+ D = .false.
+ if (async) then
+ read(lun, asynchronous='yes') B, D
+ wait(lun)
+ else
+ read(lun) B, D
+ endif
+
+ if (B .neqv. .true.) stop 11
+ if (any (D .neqv. [.false., .true., .true., .true., .true., &
+ .false., .true., .false., .true., .true.])) stop 12
+ ! 6 7 8 9 10
+ if (transfer(B, 0_16) /= 1) stop 13
+ if (any ([(transfer(D(i),0_16), i=1,10)] &
+ /= [0, 1, 1, 1, 1, 0, 1, 0, 1, 1])) stop 14
+ !1 2 3 4 5 6 7 8 9 10
+end
+
+end
@@ -1126,8 +1126,64 @@ unformatted_read (st_parameter_dt *dtp, bt type,
size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems);
- if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
- && kind != 1)
+ /* GFORTRAN_LEGACY_LOGICAL_READ: A large set of Fortran compiler use -1
+ for .TRUE. - at least in legacy mode. By consistently using 1 and 0,
+ one avoids issues when comparing two logical variables and with .not.
+ which might use a simple bit flip (gfortran: "xor 1", some other
+ compilers "xor -1").
+ Note: gfortran uses != 0 for Boolean checks while other compilers
+ only check the last bit, i.e. 0 = 2 = .false, 1 = 3 = .true.
+ Below, we follow gfortran and use != 0, which is fine for -1 logicals.
+ If changing to the other convention, move this after the endian
+ conversion! */
+ if (unlikely (options.legacy_logical_read && type == BT_LOGICAL))
+ switch (kind)
+ {
+ case 1:
+ for (size_t i = 0; i < nelems; ++i)
+ {
+ GFC_INTEGER_1 *tmp = (GFC_INTEGER_1*) dest;
+ *tmp = (GFC_INTEGER_1) *tmp ? 1 : 0;
+ dest += sizeof (GFC_INTEGER_1);
+ }
+ break;
+ case 2:
+ for (size_t i = 0; i < nelems; ++i)
+ {
+ GFC_INTEGER_2 *tmp = (GFC_INTEGER_2*) dest;
+ *tmp = (GFC_INTEGER_2) *tmp ? 1 : 0;
+ dest += sizeof (GFC_INTEGER_2);
+ }
+ break;
+ case 4:
+ for (size_t i = 0; i < nelems; ++i)
+ {
+ GFC_INTEGER_4 *tmp = (GFC_INTEGER_4*) dest;
+ *tmp = (GFC_INTEGER_4) *tmp ? 1 : 0;
+ dest += sizeof (GFC_INTEGER_4);
+ }
+ break;
+ case 8:
+ for (size_t i = 0; i < nelems; ++i)
+ {
+ GFC_INTEGER_8 *tmp = (GFC_INTEGER_8*) dest;
+ *tmp = (GFC_INTEGER_8) *tmp ? 1 : 0;
+ dest += sizeof (GFC_INTEGER_8);
+ }
+ break;
+#ifdef HAVE_GFC_INTEGER_16
+ case 16:
+ for (size_t i = 0; i < nelems; ++i)
+ {
+ GFC_INTEGER_16 *tmp = (GFC_INTEGER_16*) dest;
+ *tmp = (GFC_INTEGER_16) *tmp ? 1 : 0;
+ dest += sizeof (GFC_INTEGER_16);
+ }
+ break;
+#endif /* HAVE_GFC_INTEGER_16 */
+ }
+ else if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
+ && kind != 1)
{
/* Handle wide chracters. */
if (type == BT_CHARACTER)
@@ -532,8 +532,8 @@ typedef GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_INTEGER_4) gfc_full_a
typedef struct
{
- int stdin_unit, stdout_unit, stderr_unit, optional_plus;
- int locus;
+ int stdin_unit, stdout_unit, stderr_unit;
+ int optional_plus, locus;
int separator_len;
const char *separator;
@@ -541,6 +541,7 @@ typedef struct
int all_unbuffered, unbuffered_preconnected;
int fpe, backtrace;
int unformatted_buffer_size, formatted_buffer_size;
+ int legacy_logical_read;
}
options_t;
@@ -206,6 +206,10 @@ static variable variable_table[] = {
{ "GFORTRAN_FORMATTED_BUFFER_SIZE", 0, &options.formatted_buffer_size,
init_integer },
+ /* If TRUE, LOGICALs on unformatted READ will be normalized to {0, 1}. */
+ { "GFORTRAN_LEGACY_LOGICAL_READ", 0, &options.legacy_logical_read,
+ init_boolean },
+
{ NULL, 0, NULL, NULL }
};