Hi,
I just pushed the attached patch to the branch. It works with the
attached test case for -mabi=ibmlongdouble and -mabi=ieeelongdouble.
The test case is not quite ready for inclusion in the test suite;
it still leaves its last data files behind, and it needs to be
dejagnuified and put with the right options into the right
directory. Not quite sure how to do this.
Still to do: the environment variables and -fconvert.
For the -fconvert option, I would like to see the same sort
of syntax as in the convert option, something like
-fconvert=r16_ieee,big-endian
but I do not know how to massage the *.opt files to accomplish
that.
Regarding specifying via environment variables: Next on
my agenda.
So, here's the patch.
Implement CONVERT specifier for OPEN.
This patch, based on Jakub's work, implements the CONVERT
specifier for the power-ieee128 brach. It allows specifying
the conversion as r16_ieee,big_endian and the other way around,
based on a table. Setting the conversion via environment
variable and via program option does not yet work.
gcc/ChangeLog:
* flag-types.h (enum gfc_convert): Add flags for
conversion.
gcc/fortran/ChangeLog:
* libgfortran.h (unit_convert): Add flags.
libgfortran/ChangeLog:
* Makefile.in: Regenerate.
* io/file_pos.c (unformatted_backspace): Mask off
R16 parts for convert.
* io/inquire.c (inquire_via_unit): Add cases for
R16 parts.
* io/open.c (st_open): Add cases for R16 conversion.
* io/transfer.c (unformatted_read): Adjust for R16 conversions.
(unformatted_write): Likewise.
(us_read): Mask of R16 bits.
(data_transfer_init): Likewiese.
(write_us_marker): Likewise.
! { dg-do run }
program tescht
implicit none
real (kind=16), parameter :: one_third = 3
call test_sanity
call test_sanity("r16_ieee")
call test_sanity("r16_ieee,big_endian")
call test_sanity("r16_ibm")
call test_sanity("big_endian,r16_ibm")
call test_ibm("r16_ibm")
call test_ibm("r16_ibm,swap")
call test_ibm("r16_ibm,big_endian")
call test_ibm("r16_ibm,little_endian")
call test_ibm("swap,r16_ibm")
call test_ibm("big_endian,r16_ibm")
call test_ibm("little_endian,r16_ibm")
contains
subroutine test_sanity(convert)
character(len=*), optional :: convert
real(kind=16) :: a, b, c, d
complex(kind=16) :: c1, c2
real(kind=16) :: arr(2)
complex(kind=16), dimension(10) :: c_arr
real(kind=16), dimension(10) :: a_arr, b_arr
integer :: i
if (present(convert)) then
open(10,file="dat",form="unformatted",convert=convert,status="replace")
else
open(10,file="dat",form="unformatted",status="replace")
end if
a = atan(1._16)*4
! Writing a single value and reading it back again
write (10) a
rewind (10)
read (10) b
if (abs(a-b) > 1e-30) stop 10
! Writing out a KIND=16 complex number and reading
! it back again
rewind(10)
c1 = cmplx(a, one_third,16)
rewind(10)
write (10) c1
rewind(10)
c2 = 0
read (10) c2
if (abs(c1 - c2) > 1e-10) stop 11
! Reading it back in as two reals
rewind(10)
read (10) c,d
if (abs(c-a) > 1e-30 .or. abs(d-one_third) > 1e-30) stop 12
! Reading it back as an array of two reals
rewind(10)
read (10) arr
if (abs(arr(1) - a) > 1e-30 .or. abs(arr(2) - one_third) > 1e-30) stop 13
close(10)
! Writing out a complex array
c_arr = [(1._16/(1._16+cmplx(0,i,16)),i=1,size(c_arr))]
rewind(10)
write (10) c_arr
rewind(10)
read (10) (a_arr(i), b_arr(i),i=1,10)
if (any (abs(real(c_arr)-a_arr) > 1e-30) .or. any(abs(aimag(c_arr)-b_arr) > 1e-30)) stop 14
end subroutine test_sanity
subroutine test_ibm(convert)
! Specific checks for writing and reading IBM long doubles as pairs
! of doubles.
character(len=*) :: convert
double precision:: x1, x2, x3, x4
real(kind=16) :: a, b, c
complex(kind=16) :: c1, c2
real(kind=16) :: rf(2)
a = atan(1._16)*4
open (10,file=convert // ".dat",status="replace",form ="unformatted",convert=convert)
! Writing a single value and reading it back again
write (10) a
rewind(10)
read (10) b
if (abs(a-b) > 1e-30) stop 1
return
! Writing out a KIND=16 value and reading it back again as a
! pair of doubles.
rewind(10)
read (10) x1, x2
b = real(x1,kind=16) + real(x2,kind=16)
if (abs(a-b) > 1e-30) stop 2
! Writing out a KIND=16 complex number and reading
! it back again
rewind (10)
c1 = cmplx(a, one_third,16)
write (10) c1
rewind (10)
read (10) c2
if (abs(c1 - c2) > 1e-10) stop 3
! Reading it back as a KIND=16 REAL array
rewind(10)
read (10) rf
if (abs(rf(1) - a) > 1e-30 .or. abs(rf(2) - one_third) > 1e-30) stop 4
! Reading it back as four double precision values
rewind (10)
read (10) x1, x2, x3, x4
b = real(x1,kind=16) + real(x2,kind=16)
if (abs(b-a) > 1e-30) stop 4
c = real(x3,kind=16) + real(x4,kind=16)
if (abs(c-one_third) > 1e-30) stop 5
close (10)
end subroutine test_ibm
end program tescht
diff --git a/gcc/flag-types.h b/gcc/flag-types.h
index cfd2a5f6f50..345592aea6d 100644
--- a/gcc/flag-types.h
+++ b/gcc/flag-types.h
@@ -424,7 +424,15 @@ enum gfc_convert
GFC_FLAG_CONVERT_NATIVE = 0,
GFC_FLAG_CONVERT_SWAP,
GFC_FLAG_CONVERT_BIG,
- GFC_FLAG_CONVERT_LITTLE
+ GFC_FLAG_CONVERT_LITTLE,
+ GFC_FLAG_CONVERT_R16_IEEE = 4,
+ GFC_FLAG_CONVERT_R16_IEEE_SWAP,
+ GFC_FLAG_CONVERT_R16_IEEE_BIG,
+ GFC_FLAG_CONVERT_R16_IEEE_LITTLE,
+ GFC_FLAG_CONVERT_R16_IBM = 8,
+ GFC_FLAG_CONVERT_R16_IBM_SWAP,
+ GFC_FLAG_CONVERT_R16_IBM_BIG,
+ GFC_FLAG_CONVERT_R16_IBM_LITTLE,
};
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 13cefdb677b..146a00d2eb6 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -86,14 +86,22 @@ along with GCC; see the file COPYING3. If not see
#define GFC_INVALID_UNIT -3
/* Possible values for the CONVERT I/O specifier. */
-/* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flags.h. */
+/* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flag-types.h. */
typedef enum
{
GFC_CONVERT_NONE = -1,
GFC_CONVERT_NATIVE = 0,
GFC_CONVERT_SWAP,
GFC_CONVERT_BIG,
- GFC_CONVERT_LITTLE
+ GFC_CONVERT_LITTLE,
+ GFC_CONVERT_R16_IEEE = 4,
+ GFC_CONVERT_R16_IEEE_SWAP,
+ GFC_CONVERT_R16_IEEE_BIG,
+ GFC_CONVERT_R16_IEEE_LITTLE,
+ GFC_CONVERT_R16_IBM = 8,
+ GFC_CONVERT_R16_IBM_SWAP,
+ GFC_CONVERT_R16_IBM_BIG,
+ GFC_CONVERT_R16_IBM_LITTLE,
}
unit_convert;
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index 5de1b19ea0b..dc2a95c082f 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -719,6 +719,7 @@ pdfdir = @pdfdir@
prefix = @prefix@
program_transform_name = @program_transform_name@
psdir = @psdir@
+runstatedir = @runstatedir@
sbindir = @sbindir@
sharedstatedir = @sharedstatedir@
srcdir = @srcdir@
diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c
index 7e71ca577e0..aaf8b0aef1f 100644
--- a/libgfortran/io/file_pos.c
+++ b/libgfortran/io/file_pos.c
@@ -104,6 +104,11 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
ssize_t length;
int continued;
char p[sizeof (GFC_INTEGER_8)];
+ int convert = u->flags.convert;
+
+#ifdef HAVE_GFC_REAL_17
+ convert &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+#endif
if (compile_options.record_marker == 0)
length = sizeof (GFC_INTEGER_4);
@@ -119,7 +124,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
goto io_error;
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
- if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
+ if (likely (convert == GFC_CONVERT_NATIVE))
{
switch (length)
{
diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c
index 05e2c1fdf18..6f7e15904ef 100644
--- a/libgfortran/io/inquire.c
+++ b/libgfortran/io/inquire.c
@@ -642,6 +642,24 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit *u)
p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
break;
+#ifdef HAVE_GFC_REAL_17
+ case GFC_CONVERT_NATIVE | GFC_CONVERT_R16_IEEE:
+ p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "BIG_ENDIAN,R16_IEEE" : "LITTLE_ENDIAN,R16_IEEE";
+ break;
+
+ case GFC_CONVERT_SWAP | GFC_CONVERT_R16_IEEE:
+ p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "LITTLE_ENDIAN,R16_IEEE" : "BIG_ENDIAN,R16_IEEE";
+ break;
+
+ case GFC_CONVERT_NATIVE | GFC_CONVERT_R16_IBM:
+ p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "BIG_ENDIAN,R16_IBM" : "LITTLE_ENDIAN,R16_IBM";
+ break;
+
+ case GFC_CONVERT_SWAP | GFC_CONVERT_R16_IBM:
+ p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "LITTLE_ENDIAN,R16_IBM" : "BIG_ENDIAN,R16_IBM";
+ break;
+#endif
+
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
}
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
index 3837d567048..56ab21bc7fb 100644
--- a/libgfortran/io/open.c
+++ b/libgfortran/io/open.c
@@ -153,6 +153,28 @@ static const st_option convert_opt[] =
{ "swap", GFC_CONVERT_SWAP},
{ "big_endian", GFC_CONVERT_BIG},
{ "little_endian", GFC_CONVERT_LITTLE},
+#ifdef HAVE_GFC_REAL_17
+ /* Rather than write a special parsing routine, enumerate all the
+ possibilities here. */
+ { "r16_ieee", GFC_CONVERT_R16_IEEE},
+ { "r16_ibm", GFC_CONVERT_R16_IBM},
+ { "native,r16_ieee", GFC_CONVERT_R16_IEEE},
+ { "native,r16_ibm", GFC_CONVERT_R16_IBM},
+ { "r16_ieee,native", GFC_CONVERT_R16_IEEE},
+ { "r16_ibm,native", GFC_CONVERT_R16_IBM},
+ { "swap,r16_ieee", GFC_CONVERT_R16_IEEE_SWAP},
+ { "swap,r16_ibm", GFC_CONVERT_R16_IBM_SWAP},
+ { "r16_ieee,swap", GFC_CONVERT_R16_IEEE_SWAP},
+ { "r16_ibm,swap", GFC_CONVERT_R16_IBM_SWAP},
+ { "big_endian,r16_ieee", GFC_CONVERT_R16_IEEE_BIG},
+ { "big_endian,r16_ibm", GFC_CONVERT_R16_IBM_BIG},
+ { "r16_ieee,big_endian", GFC_CONVERT_R16_IEEE_BIG},
+ { "r16_ibm,big_endian", GFC_CONVERT_R16_IBM_BIG},
+ { "little_endian,r16_ieee", GFC_CONVERT_R16_IEEE_LITTLE},
+ { "little_endian,r16_ibm", GFC_CONVERT_R16_IBM_LITTLE},
+ { "r16_ieee,little_endian", GFC_CONVERT_R16_IEEE_LITTLE},
+ { "r16_ibm,little_endian", GFC_CONVERT_R16_IBM_LITTLE},
+#endif
{ NULL, 0}
};
@@ -820,7 +842,14 @@ st_open (st_parameter_open *opp)
else
conv = compile_options.convert;
}
-
+
+ flags.convert = 0;
+
+#ifdef HAVE_GFC_REAL_17
+ flags.convert = conv & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+ conv &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+#endif
+
switch (conv)
{
case GFC_CONVERT_NATIVE:
@@ -840,7 +869,7 @@ st_open (st_parameter_open *opp)
break;
}
- flags.convert = conv;
+ flags.convert |= conv;
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index e44b2df6058..1e738741960 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1088,6 +1088,8 @@ static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
+ unit_convert convert;
+
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
@@ -1126,8 +1128,8 @@ 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)
+ convert = dtp->u.p.current_unit->flags.convert;
+ if (unlikely (convert != GFC_CONVERT_NATIVE) && kind != 1)
{
/* Handle wide chracters. */
if (type == BT_CHARACTER)
@@ -1142,7 +1144,50 @@ unformatted_read (st_parameter_dt *dtp, bt type,
nelems *= 2;
size /= 2;
}
+#ifndef HAVE_GFC_REAL_17
bswap_array (dest, dest, size, nelems);
+#else
+ unit_convert bswap = convert & ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+ if (bswap == GFC_CONVERT_SWAP)
+ bswap_array (dest, dest, size, nelems);
+
+ if ((convert & GFC_CONVERT_R16_IEEE)
+ && kind == 16
+ && (type == BT_REAL || type == BT_COMPLEX))
+ {
+ char *pd = dest;
+ for (size_t i = 0; i < nelems; i++)
+ {
+ GFC_REAL_16 r16;
+ GFC_REAL_17 r17;
+ memcpy (&r17, pd, 16);
+ r16 = r17;
+ memcpy (pd, &r16, 16);
+ pd += size;
+ }
+ }
+ else if ((dtp->u.p.current_unit->flags.convert & GFC_CONVERT_R16_IBM)
+ && kind == 17
+ && (type == BT_REAL || type == BT_COMPLEX))
+ {
+ if (type == BT_COMPLEX && size == 32)
+ {
+ nelems *= 2;
+ size /= 2;
+ }
+
+ char *pd = dest;
+ for (size_t i = 0; i < nelems; i++)
+ {
+ GFC_REAL_16 r16;
+ GFC_REAL_17 r17;
+ memcpy (&r16, pd, 16);
+ r17 = r16;
+ memcpy (pd, &r17, 16);
+ pd += size;
+ }
+ }
+#endif /* HAVE_GFC_REAL_17. */
}
}
@@ -1156,6 +1201,8 @@ static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
+ unit_convert convert;
+
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
@@ -1190,8 +1237,14 @@ unformatted_write (st_parameter_dt *dtp, bt type,
return;
}
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
- || kind == 1)
+ convert = dtp->u.p.current_unit->flags.convert;
+ if (likely (convert == GFC_CONVERT_NATIVE) || kind == 1
+#ifdef HAVE_GFC_REAL_17
+ || ((type == BT_REAL || type == BT_COMPLEX)
+ && ((kind == 16 && convert == GFC_CONVERT_R16_IBM)
+ || (kind == 17 && convert == GFC_CONVERT_R16_IEEE)))
+#endif
+ )
{
size_t stride = type == BT_CHARACTER ?
size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
@@ -1233,9 +1286,50 @@ unformatted_write (st_parameter_dt *dtp, bt type,
else
nc = nrem;
- bswap_array (buffer, p, size, nc);
+#ifdef HAVE_GFC_REAL_17
+ if ((dtp->u.p.current_unit->flags.convert & GFC_CONVERT_R16_IEEE)
+ && kind == 16
+ && (type == BT_REAL || type == BT_COMPLEX))
+ {
+ for (size_t i = 0; i < nc; i++)
+ {
+ GFC_REAL_16 r16;
+ GFC_REAL_17 r17;
+ memcpy (&r16, p, 16);
+ r17 = r16;
+ memcpy (&buffer[i * 16], &r17, 16);
+ p += 16;
+ }
+ if ((dtp->u.p.current_unit->flags.convert
+ & ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM))
+ == GFC_CONVERT_SWAP)
+ bswap_array (buffer, buffer, size, nc);
+ }
+ else if ((dtp->u.p.current_unit->flags.convert & GFC_CONVERT_R16_IBM)
+ && kind == 17
+ && (type == BT_REAL || type == BT_COMPLEX))
+ {
+ for (size_t i = 0; i < nc; i++)
+ {
+ GFC_REAL_16 r16;
+ GFC_REAL_17 r17;
+ memcpy (&r17, p, 16);
+ r16 = r17;
+ memcpy (&buffer[i * 16], &r16, 16);
+ p += 16;
+ }
+ if ((dtp->u.p.current_unit->flags.convert
+ & ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM))
+ == GFC_CONVERT_SWAP)
+ bswap_array (buffer, buffer, size, nc);
+ }
+ else
+#endif
+ {
+ bswap_array (buffer, p, size, nc);
+ p += size * nc;
+ }
write_buf (dtp, buffer, size * nc);
- p += size * nc;
nrem -= nc;
}
while (nrem > 0);
@@ -2691,8 +2785,12 @@ us_read (st_parameter_dt *dtp, int continued)
return;
}
+ int convert = dtp->u.p.current_unit->flags.convert;
+#ifdef HAVE_GFC_REAL_17
+ convert &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+#endif
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
+ if (likely (convert == GFC_CONVERT_NATIVE))
{
switch (nr)
{
@@ -2894,6 +2992,13 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert;
+ u_flags.convert = 0;
+
+#ifdef HAVE_GFC_REAL_17
+ u_flags.convert = conv & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+ conv &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+#endif
+
switch (conv)
{
case GFC_CONVERT_NATIVE:
@@ -2913,7 +3018,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
break;
}
- u_flags.convert = conv;
+ u_flags.convert |= conv;
opp.common = dtp->common;
opp.common.flags &= IOPARM_COMMON_MASK;
@@ -3710,8 +3815,12 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
else
len = compile_options.record_marker;
+ int convert = dtp->u.p.current_unit->flags.convert;
+#ifdef HAVE_GFC_REAL_17
+ convert &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
+#endif
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
+ if (likely (convert == GFC_CONVERT_NATIVE))
{
switch (len)
{
