mirror of git://gcc.gnu.org/git/gcc.git
re PR fortran/23815 (Add -byteswapio flag)
2005-12-10 Thomas Koenig <Thomas.Koenig@online.de> PR fortran/23815 * io.c (top level): Add convert to io_tag. (resolve_tag): convert is GFC_STD_GNU. (match_open_element): Add convert. (gfc_free_open): Likewise. (gfc_resolve_open): Likewise. (gfc_free_inquire): Likewise. (match_inquire_element): Likewise. * dump-parse-tree.c (gfc_show_code_node): Add convet for open and inquire. gfortran.h: Add convert to gfc_open and gfc_inquire. * trans-io.c (gfc_trans_open): Add convert. (gfc_trans_inquire): Likewise. * ioparm.def: Add convert to open and inquire. * gfortran.texi: Document CONVERT. 2005-12-10 Thomas Koenig <Thomas.Koenig@online.de> PR fortran/23815 * io/file_pos.c (unformatted_backspace): If flags.convert does not equal CONVERT_NATIVE, reverse the record marker. * io/open.c: Add convert_opt[]. (st_open): If no convert option is given, set CONVERT_NATIVE. If CONVERT_BIG or CONVERT_LITTLE are given, set flags.convert to CONVERT_NATIVE or CONVERT_SWAP (depending on wether we have a big- or little-endian system). * io/transfer.c (unformatted_read): Remove unused attribute from arguments. If we need to reverse bytes, break up large transfers into a loop. Split complex numbers into its two parts. (unformatted_write): Likewise. (us_read): If flags.convert does not equal CONVERT_NATIVE, reverse the record marker. (next_record_w): Likewise. (reverse_memcpy): New function. * io/inquire.c (inquire_via_unit): Implement convert. * io/io.h (top level): Add enum unit_convert. Add convert to st_parameter_open and st_parameter_inquire. Define IOPARM_OPEN_HAS_CONVERT and IOPARM_INQUIRE_HAS_CONVERT. Increase padding for st_parameter_dt. Declare reverse_memcpy(). 2005-12-10 Thomas Koenig <Thomas.Koenig@online.de> PR fortran/23815 * gfortran.dg/unf_io_convert_1.f90: New test. * gfortran.dg/unf_io_convert_2.f90: New test. * gfortran.dg/unf_io_convert_3.f90: New test. From-SVN: r108358
This commit is contained in:
parent
775fe6e36d
commit
181c9f4a9b
|
@ -1,3 +1,21 @@
|
||||||
|
2005-12-10 Thomas Koenig <Thomas.Koenig@online.de>
|
||||||
|
|
||||||
|
PR fortran/23815
|
||||||
|
* io.c (top level): Add convert to io_tag.
|
||||||
|
(resolve_tag): convert is GFC_STD_GNU.
|
||||||
|
(match_open_element): Add convert.
|
||||||
|
(gfc_free_open): Likewise.
|
||||||
|
(gfc_resolve_open): Likewise.
|
||||||
|
(gfc_free_inquire): Likewise.
|
||||||
|
(match_inquire_element): Likewise.
|
||||||
|
* dump-parse-tree.c (gfc_show_code_node): Add
|
||||||
|
convet for open and inquire.
|
||||||
|
gfortran.h: Add convert to gfc_open and gfc_inquire.
|
||||||
|
* trans-io.c (gfc_trans_open): Add convert.
|
||||||
|
(gfc_trans_inquire): Likewise.
|
||||||
|
* ioparm.def: Add convert to open and inquire.
|
||||||
|
* gfortran.texi: Document CONVERT.
|
||||||
|
|
||||||
2005-12-09 Roger Sayle <roger@eyesopen.com>
|
2005-12-09 Roger Sayle <roger@eyesopen.com>
|
||||||
|
|
||||||
PR fortran/22527
|
PR fortran/22527
|
||||||
|
|
|
@ -1148,6 +1148,11 @@ gfc_show_code_node (int level, gfc_code * c)
|
||||||
gfc_status (" PAD=");
|
gfc_status (" PAD=");
|
||||||
gfc_show_expr (open->pad);
|
gfc_show_expr (open->pad);
|
||||||
}
|
}
|
||||||
|
if (open->convert)
|
||||||
|
{
|
||||||
|
gfc_status (" CONVERT=");
|
||||||
|
gfc_show_expr (open->convert);
|
||||||
|
}
|
||||||
if (open->err != NULL)
|
if (open->err != NULL)
|
||||||
gfc_status (" ERR=%d", open->err->value);
|
gfc_status (" ERR=%d", open->err->value);
|
||||||
|
|
||||||
|
@ -1349,6 +1354,11 @@ gfc_show_code_node (int level, gfc_code * c)
|
||||||
gfc_status (" PAD=");
|
gfc_status (" PAD=");
|
||||||
gfc_show_expr (i->pad);
|
gfc_show_expr (i->pad);
|
||||||
}
|
}
|
||||||
|
if (i->convert)
|
||||||
|
{
|
||||||
|
gfc_status (" CONVERT=");
|
||||||
|
gfc_show_expr (i->convert);
|
||||||
|
}
|
||||||
|
|
||||||
if (i->err != NULL)
|
if (i->err != NULL)
|
||||||
gfc_status (" ERR=%d", i->err->value);
|
gfc_status (" ERR=%d", i->err->value);
|
||||||
|
|
|
@ -1309,7 +1309,7 @@ gfc_alloc;
|
||||||
typedef struct
|
typedef struct
|
||||||
{
|
{
|
||||||
gfc_expr *unit, *file, *status, *access, *form, *recl,
|
gfc_expr *unit, *file, *status, *access, *form, *recl,
|
||||||
*blank, *position, *action, *delim, *pad, *iostat, *iomsg;
|
*blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert;
|
||||||
gfc_st_label *err;
|
gfc_st_label *err;
|
||||||
}
|
}
|
||||||
gfc_open;
|
gfc_open;
|
||||||
|
@ -1336,7 +1336,7 @@ typedef struct
|
||||||
gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
|
gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
|
||||||
*name, *access, *sequential, *direct, *form, *formatted,
|
*name, *access, *sequential, *direct, *form, *formatted,
|
||||||
*unformatted, *recl, *nextrec, *blank, *position, *action, *read,
|
*unformatted, *recl, *nextrec, *blank, *position, *action, *read,
|
||||||
*write, *readwrite, *delim, *pad, *iolength, *iomsg;
|
*write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert;
|
||||||
|
|
||||||
gfc_st_label *err;
|
gfc_st_label *err;
|
||||||
|
|
||||||
|
|
|
@ -587,6 +587,7 @@ of extensions, and @option{-std=legacy} allows both without warning.
|
||||||
* Implicitly interconvert LOGICAL and INTEGER::
|
* Implicitly interconvert LOGICAL and INTEGER::
|
||||||
* Hollerith constants support::
|
* Hollerith constants support::
|
||||||
* Cray pointers::
|
* Cray pointers::
|
||||||
|
* CONVERT specifier::
|
||||||
@end menu
|
@end menu
|
||||||
|
|
||||||
@node Old-style kind specifications
|
@node Old-style kind specifications
|
||||||
|
@ -930,6 +931,42 @@ pointees are passed as arguments, they are treated as ordinary
|
||||||
variables in the invoked function. Subsequent changes to the pointer
|
variables in the invoked function. Subsequent changes to the pointer
|
||||||
will not change the base address of the array that was passed.
|
will not change the base address of the array that was passed.
|
||||||
|
|
||||||
|
@node CONVERT specifier
|
||||||
|
@section CONVERT specifier
|
||||||
|
@cindex CONVERT specifier
|
||||||
|
|
||||||
|
gfortran allows the conversion of unformatted data between little-
|
||||||
|
and big-endian representation to facilitate moving of data
|
||||||
|
between different systems. The conversion is indicated with
|
||||||
|
the @code{CONVERT} specifier on the @code{OPEN} statement.
|
||||||
|
|
||||||
|
Valid values for @code{CONVERT} are:
|
||||||
|
@itemize @w{}
|
||||||
|
@item @code{CONVERT='NATIVE'} Use the native format. This is the default.
|
||||||
|
@item @code{CONVERT='SWAP'} Swap between little- and big-endian.
|
||||||
|
@item @code{CONVERT='LITTLE_ENDIAN'} Use the little-endian format
|
||||||
|
for unformatted files.
|
||||||
|
@item @code{CONVERT='BIG_ENDIAN'} Use the big-endian format for
|
||||||
|
unformatted files.
|
||||||
|
@end itemize
|
||||||
|
|
||||||
|
Using the option could look like this:
|
||||||
|
@smallexample
|
||||||
|
open(file='big.dat',form='unformatted',access='sequential', &
|
||||||
|
convert='big_endian')
|
||||||
|
@end smallexample
|
||||||
|
|
||||||
|
The value of the conversion can be queried by using
|
||||||
|
@code{INQUIRE(CONVERT=ch)}. The values returned are
|
||||||
|
@code{'BIG_ENDIAN'} and @code{'LITTLE_ENDIAN'}.
|
||||||
|
|
||||||
|
@code{CONVERT} works between big- and little-endian for
|
||||||
|
@code{INTEGER} values of all supported kinds and for @code{REAL}
|
||||||
|
on IEEE sytems of kinds 4 and 8. Conversion between different
|
||||||
|
``extended double'' types on different architectures such as
|
||||||
|
m68k and x86_64, which gfortran
|
||||||
|
supports as @code{REAL(KIND=10)} will probably not work.
|
||||||
|
|
||||||
@c ---------------------------------------------------------------------
|
@c ---------------------------------------------------------------------
|
||||||
@include intrinsic.texi
|
@include intrinsic.texi
|
||||||
@c ---------------------------------------------------------------------
|
@c ---------------------------------------------------------------------
|
||||||
|
|
|
@ -78,6 +78,7 @@ static const io_tag
|
||||||
tag_s_delim = {"DELIM", " delim = %v", BT_CHARACTER},
|
tag_s_delim = {"DELIM", " delim = %v", BT_CHARACTER},
|
||||||
tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER},
|
tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER},
|
||||||
tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER},
|
tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER},
|
||||||
|
tag_convert = {"CONVERT", " convert = %e", BT_CHARACTER},
|
||||||
tag_err = {"ERR", " err = %l", BT_UNKNOWN},
|
tag_err = {"ERR", " err = %l", BT_UNKNOWN},
|
||||||
tag_end = {"END", " end = %l", BT_UNKNOWN},
|
tag_end = {"END", " end = %l", BT_UNKNOWN},
|
||||||
tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
|
tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
|
||||||
|
@ -1051,6 +1052,12 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
|
||||||
&e->where) == FAILURE)
|
&e->where) == FAILURE)
|
||||||
return FAILURE;
|
return FAILURE;
|
||||||
}
|
}
|
||||||
|
if (tag == &tag_convert)
|
||||||
|
{
|
||||||
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
|
||||||
|
&e->where) == FAILURE)
|
||||||
|
return FAILURE;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
return SUCCESS;
|
return SUCCESS;
|
||||||
|
@ -1104,6 +1111,9 @@ match_open_element (gfc_open * open)
|
||||||
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
||||||
return m;
|
return m;
|
||||||
m = match_ltag (&tag_err, &open->err);
|
m = match_ltag (&tag_err, &open->err);
|
||||||
|
if (m != MATCH_NO)
|
||||||
|
return m;
|
||||||
|
m = match_etag (&tag_convert, &open->convert);
|
||||||
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
||||||
return m;
|
return m;
|
||||||
|
|
||||||
|
@ -1133,6 +1143,7 @@ gfc_free_open (gfc_open * open)
|
||||||
gfc_free_expr (open->action);
|
gfc_free_expr (open->action);
|
||||||
gfc_free_expr (open->delim);
|
gfc_free_expr (open->delim);
|
||||||
gfc_free_expr (open->pad);
|
gfc_free_expr (open->pad);
|
||||||
|
gfc_free_expr (open->convert);
|
||||||
|
|
||||||
gfc_free (open);
|
gfc_free (open);
|
||||||
}
|
}
|
||||||
|
@ -1158,6 +1169,7 @@ gfc_resolve_open (gfc_open * open)
|
||||||
RESOLVE_TAG (&tag_e_action, open->action);
|
RESOLVE_TAG (&tag_e_action, open->action);
|
||||||
RESOLVE_TAG (&tag_e_delim, open->delim);
|
RESOLVE_TAG (&tag_e_delim, open->delim);
|
||||||
RESOLVE_TAG (&tag_e_pad, open->pad);
|
RESOLVE_TAG (&tag_e_pad, open->pad);
|
||||||
|
RESOLVE_TAG (&tag_convert, open->convert);
|
||||||
|
|
||||||
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
|
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
|
||||||
return FAILURE;
|
return FAILURE;
|
||||||
|
@ -2438,6 +2450,7 @@ gfc_free_inquire (gfc_inquire * inquire)
|
||||||
gfc_free_expr (inquire->delim);
|
gfc_free_expr (inquire->delim);
|
||||||
gfc_free_expr (inquire->pad);
|
gfc_free_expr (inquire->pad);
|
||||||
gfc_free_expr (inquire->iolength);
|
gfc_free_expr (inquire->iolength);
|
||||||
|
gfc_free_expr (inquire->convert);
|
||||||
|
|
||||||
gfc_free (inquire);
|
gfc_free (inquire);
|
||||||
}
|
}
|
||||||
|
@ -2479,6 +2492,7 @@ match_inquire_element (gfc_inquire * inquire)
|
||||||
RETM m = match_vtag (&tag_s_delim, &inquire->delim);
|
RETM m = match_vtag (&tag_s_delim, &inquire->delim);
|
||||||
RETM m = match_vtag (&tag_s_pad, &inquire->pad);
|
RETM m = match_vtag (&tag_s_pad, &inquire->pad);
|
||||||
RETM m = match_vtag (&tag_iolength, &inquire->iolength);
|
RETM m = match_vtag (&tag_iolength, &inquire->iolength);
|
||||||
|
RETM m = match_vtag (&tag_convert, &inquire->convert);
|
||||||
RETM return MATCH_NO;
|
RETM return MATCH_NO;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -2632,6 +2646,7 @@ gfc_resolve_inquire (gfc_inquire * inquire)
|
||||||
RESOLVE_TAG (&tag_s_delim, inquire->delim);
|
RESOLVE_TAG (&tag_s_delim, inquire->delim);
|
||||||
RESOLVE_TAG (&tag_s_pad, inquire->pad);
|
RESOLVE_TAG (&tag_s_pad, inquire->pad);
|
||||||
RESOLVE_TAG (&tag_iolength, inquire->iolength);
|
RESOLVE_TAG (&tag_iolength, inquire->iolength);
|
||||||
|
RESOLVE_TAG (&tag_convert, inquire->convert);
|
||||||
|
|
||||||
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
|
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
|
||||||
return FAILURE;
|
return FAILURE;
|
||||||
|
|
|
@ -25,6 +25,7 @@ IOPARM (open, position, 1 << 13, char1)
|
||||||
IOPARM (open, action, 1 << 14, char2)
|
IOPARM (open, action, 1 << 14, char2)
|
||||||
IOPARM (open, delim, 1 << 15, char1)
|
IOPARM (open, delim, 1 << 15, char1)
|
||||||
IOPARM (open, pad, 1 << 16, char2)
|
IOPARM (open, pad, 1 << 16, char2)
|
||||||
|
IOPARM (open, convert, 1 << 17, char1)
|
||||||
IOPARM (close, common, 0, common)
|
IOPARM (close, common, 0, common)
|
||||||
IOPARM (close, status, 1 << 7, char1)
|
IOPARM (close, status, 1 << 7, char1)
|
||||||
IOPARM (filepos, common, 0, common)
|
IOPARM (filepos, common, 0, common)
|
||||||
|
@ -51,6 +52,7 @@ IOPARM (inquire, unformatted, 1 << 25, char1)
|
||||||
IOPARM (inquire, read, 1 << 26, char2)
|
IOPARM (inquire, read, 1 << 26, char2)
|
||||||
IOPARM (inquire, write, 1 << 27, char1)
|
IOPARM (inquire, write, 1 << 27, char1)
|
||||||
IOPARM (inquire, readwrite, 1 << 28, char2)
|
IOPARM (inquire, readwrite, 1 << 28, char2)
|
||||||
|
IOPARM (inquire, convert, 1 << 29, char1)
|
||||||
#ifndef IOPARM_dt_list_format
|
#ifndef IOPARM_dt_list_format
|
||||||
#define IOPARM_dt_list_format (1 << 7)
|
#define IOPARM_dt_list_format (1 << 7)
|
||||||
#define IOPARM_dt_namelist_read_mode (1 << 8)
|
#define IOPARM_dt_namelist_read_mode (1 << 8)
|
||||||
|
|
|
@ -791,6 +791,10 @@ gfc_trans_open (gfc_code * code)
|
||||||
if (p->err)
|
if (p->err)
|
||||||
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
||||||
|
|
||||||
|
if (p->convert)
|
||||||
|
mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
|
||||||
|
p->convert);
|
||||||
|
|
||||||
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
||||||
|
|
||||||
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
||||||
|
@ -1073,6 +1077,10 @@ gfc_trans_inquire (gfc_code * code)
|
||||||
if (p->err)
|
if (p->err)
|
||||||
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
||||||
|
|
||||||
|
if (p->convert)
|
||||||
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
|
||||||
|
p->convert);
|
||||||
|
|
||||||
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
||||||
|
|
||||||
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
||||||
|
|
|
@ -1,3 +1,10 @@
|
||||||
|
2005-12-10 Thomas Koenig <Thomas.Koenig@online.de>
|
||||||
|
|
||||||
|
PR fortran/23815
|
||||||
|
* gfortran.dg/unf_io_convert_1.f90: New test.
|
||||||
|
* gfortran.dg/unf_io_convert_2.f90: New test.
|
||||||
|
* gfortran.dg/unf_io_convert_3.f90: New test.
|
||||||
|
|
||||||
2005-12-10 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
|
2005-12-10 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
|
||||||
|
|
||||||
PR testsuite/20772
|
PR testsuite/20772
|
||||||
|
|
|
@ -0,0 +1,95 @@
|
||||||
|
! { dg-do run }
|
||||||
|
! { dg-options "-pedantic" }
|
||||||
|
! This test verifies the most basic sequential unformatted I/O
|
||||||
|
! with convert="swap".
|
||||||
|
! Adapted from seq_io.f.
|
||||||
|
! write 3 records of various sizes
|
||||||
|
! then read them back
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
integer size
|
||||||
|
parameter(size=100)
|
||||||
|
logical debug
|
||||||
|
data debug /.FALSE./
|
||||||
|
! set debug to true for help in debugging failures.
|
||||||
|
integer m(2)
|
||||||
|
integer n
|
||||||
|
real*4 r(size)
|
||||||
|
integer i
|
||||||
|
character*4 str
|
||||||
|
|
||||||
|
m(1) = Z'11223344'
|
||||||
|
m(2) = Z'55667788'
|
||||||
|
n = Z'77AABBCC'
|
||||||
|
str = 'asdf'
|
||||||
|
do i = 1,size
|
||||||
|
r(i) = i
|
||||||
|
end do
|
||||||
|
open(9,form="unformatted",access="sequential",convert="swap") ! { dg-warning "Extension: CONVERT" }
|
||||||
|
write(9) m ! an array of 2
|
||||||
|
write(9) n ! an integer
|
||||||
|
write(9) r ! an array of reals
|
||||||
|
write(9)str ! String
|
||||||
|
! zero all the results so we can compare after they are read back
|
||||||
|
do i = 1,size
|
||||||
|
r(i) = 0
|
||||||
|
end do
|
||||||
|
m(1) = 0
|
||||||
|
m(2) = 0
|
||||||
|
n = 0
|
||||||
|
str = ' '
|
||||||
|
|
||||||
|
rewind(9)
|
||||||
|
read(9) m
|
||||||
|
read(9) n
|
||||||
|
read(9) r
|
||||||
|
read(9) str
|
||||||
|
!
|
||||||
|
! check results
|
||||||
|
if (m(1).ne.Z'11223344') then
|
||||||
|
if (debug) then
|
||||||
|
print '(A,Z8)','m(1) incorrect. m(1) = ',m(1)
|
||||||
|
else
|
||||||
|
call abort
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (m(2).ne.Z'55667788') then
|
||||||
|
if (debug) then
|
||||||
|
print '(A,Z8)','m(2) incorrect. m(2) = ',m(2)
|
||||||
|
else
|
||||||
|
call abort
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (n.ne.Z'77AABBCC') then
|
||||||
|
if (debug) then
|
||||||
|
print '(A,Z8)','n incorrect. n = ',n
|
||||||
|
else
|
||||||
|
call abort
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
do i = 1,size
|
||||||
|
if (int(r(i)).ne.i) then
|
||||||
|
if (debug) then
|
||||||
|
print*,'element ',i,' was ',r(i),' should be ',i
|
||||||
|
else
|
||||||
|
call abort
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
if (str .ne. 'asdf') then
|
||||||
|
if (debug) then
|
||||||
|
print *,'str incorrect, str = ', str
|
||||||
|
else
|
||||||
|
call abort
|
||||||
|
endif
|
||||||
|
! use hexdump to look at the file "fort.9"
|
||||||
|
if (debug) then
|
||||||
|
close(9)
|
||||||
|
else
|
||||||
|
close(9,status='DELETE')
|
||||||
|
endif
|
||||||
|
end if
|
||||||
|
end program main
|
|
@ -0,0 +1,39 @@
|
||||||
|
! { dg-do run }
|
||||||
|
program main
|
||||||
|
complex(kind=4) :: c
|
||||||
|
real(kind=4) :: a(2)
|
||||||
|
integer(kind=4) :: i(2)
|
||||||
|
integer(kind=1) :: b(8)
|
||||||
|
integer(kind=8) :: j
|
||||||
|
|
||||||
|
c = (3.14, 2.71)
|
||||||
|
open (10, form="unformatted",convert="swap") ! { dg-warning "Extension: CONVERT" }
|
||||||
|
write (10) c
|
||||||
|
rewind (10)
|
||||||
|
read (10) a
|
||||||
|
if (a(1) /= 3.14 .or. a(2) /= 2.71) call abort
|
||||||
|
close(10,status="delete")
|
||||||
|
|
||||||
|
open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" }
|
||||||
|
i = (/ Z'11223344', Z'55667700' /)
|
||||||
|
write (10) i
|
||||||
|
rewind (10)
|
||||||
|
read (10) b
|
||||||
|
if (any(b /= (/ Z'11', Z'22', Z'33', Z'44', Z'55', Z'66', Z'77', Z'00' /))) &
|
||||||
|
call abort
|
||||||
|
backspace 10
|
||||||
|
read (10) j
|
||||||
|
if (j /= Z'1122334455667700') call abort
|
||||||
|
close (10, status="delete")
|
||||||
|
|
||||||
|
open (10, form="unformatted", convert="little_endian") ! { dg-warning "Extension: CONVERT" }
|
||||||
|
write (10) i
|
||||||
|
rewind (10)
|
||||||
|
read (10) b
|
||||||
|
if (any(b /= (/ Z'44', Z'33', Z'22', Z'11', Z'00', Z'77', Z'66', Z'55' /))) &
|
||||||
|
call abort
|
||||||
|
backspace 10
|
||||||
|
read (10) j
|
||||||
|
if (j /= Z'5566770011223344') call abort
|
||||||
|
|
||||||
|
end program main
|
|
@ -0,0 +1,19 @@
|
||||||
|
! { dg-do run}
|
||||||
|
! { dg-require-effective-target fortran_large_real }
|
||||||
|
program main
|
||||||
|
integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
|
||||||
|
real(kind=k) a,b,c
|
||||||
|
a = 1.1_k
|
||||||
|
open(10,convert="swap",form="unformatted") ! { dg-warning "Extension: CONVERT" }
|
||||||
|
write(10) a
|
||||||
|
backspace 10
|
||||||
|
read (10) b
|
||||||
|
close(10,status="delete")
|
||||||
|
if (a /= b) call abort
|
||||||
|
write (11) a
|
||||||
|
backspace 11
|
||||||
|
open (11,form="unformatted")
|
||||||
|
read (11) c
|
||||||
|
if (a .ne. c) call abort
|
||||||
|
close (11, status="delete")
|
||||||
|
end program main
|
|
@ -1,3 +1,30 @@
|
||||||
|
2005-12-10 Thomas Koenig <Thomas.Koenig@online.de>
|
||||||
|
|
||||||
|
PR fortran/23815
|
||||||
|
* io/file_pos.c (unformatted_backspace): If flags.convert
|
||||||
|
does not equal CONVERT_NATIVE, reverse the record marker.
|
||||||
|
* io/open.c: Add convert_opt[].
|
||||||
|
(st_open): If no convert option is given, set CONVERT_NATIVE.
|
||||||
|
If CONVERT_BIG or CONVERT_LITTLE are given, set flags.convert to
|
||||||
|
CONVERT_NATIVE or CONVERT_SWAP (depending on wether we have
|
||||||
|
a big- or little-endian system).
|
||||||
|
* io/transfer.c (unformatted_read): Remove unused attribute
|
||||||
|
from arguments.
|
||||||
|
If we need to reverse
|
||||||
|
bytes, break up large transfers into a loop. Split complex
|
||||||
|
numbers into its two parts.
|
||||||
|
(unformatted_write): Likewise.
|
||||||
|
(us_read): If flags.convert does not equal CONVERT_NATIVE,
|
||||||
|
reverse the record marker.
|
||||||
|
(next_record_w): Likewise.
|
||||||
|
(reverse_memcpy): New function.
|
||||||
|
* io/inquire.c (inquire_via_unit): Implement convert.
|
||||||
|
* io/io.h (top level): Add enum unit_convert.
|
||||||
|
Add convert to st_parameter_open and st_parameter_inquire.
|
||||||
|
Define IOPARM_OPEN_HAS_CONVERT and IOPARM_INQUIRE_HAS_CONVERT.
|
||||||
|
Increase padding for st_parameter_dt.
|
||||||
|
Declare reverse_memcpy().
|
||||||
|
|
||||||
2005-12-09 Jakub Jelinek <jakub@redhat.com>
|
2005-12-09 Jakub Jelinek <jakub@redhat.com>
|
||||||
|
|
||||||
PR libfortran/24991
|
PR libfortran/24991
|
||||||
|
|
|
@ -114,7 +114,12 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
||||||
if (p == NULL)
|
if (p == NULL)
|
||||||
goto io_error;
|
goto io_error;
|
||||||
|
|
||||||
memcpy (&m, p, sizeof (gfc_offset));
|
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
|
||||||
|
if (u->flags.convert == CONVERT_NATIVE)
|
||||||
|
memcpy (&m, p, sizeof (gfc_offset));
|
||||||
|
else
|
||||||
|
reverse_memcpy (&m, p, sizeof (gfc_offset));
|
||||||
|
|
||||||
new = file_position (u->s) - m - 2*length;
|
new = file_position (u->s) - m - 2*length;
|
||||||
if (sseek (u->s, new) == FAILURE)
|
if (sseek (u->s, new) == FAILURE)
|
||||||
goto io_error;
|
goto io_error;
|
||||||
|
|
|
@ -283,6 +283,29 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
|
||||||
|
|
||||||
cf_strcpy (iqp->pad, iqp->pad_len, p);
|
cf_strcpy (iqp->pad, iqp->pad_len, p);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
|
||||||
|
{
|
||||||
|
if (u == NULL)
|
||||||
|
p = undefined;
|
||||||
|
else
|
||||||
|
switch (u->flags.convert)
|
||||||
|
{
|
||||||
|
/* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */
|
||||||
|
case CONVERT_NATIVE:
|
||||||
|
p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
|
||||||
|
break;
|
||||||
|
|
||||||
|
case CONVERT_SWAP:
|
||||||
|
p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
|
||||||
|
break;
|
||||||
|
|
||||||
|
default:
|
||||||
|
internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
|
||||||
|
}
|
||||||
|
|
||||||
|
cf_strcpy (iqp->convert, iqp->convert_len, p);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -206,6 +206,10 @@ typedef enum
|
||||||
{READING, WRITING}
|
{READING, WRITING}
|
||||||
unit_mode;
|
unit_mode;
|
||||||
|
|
||||||
|
typedef enum
|
||||||
|
{ CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
|
||||||
|
unit_convert;
|
||||||
|
|
||||||
#define CHARACTER1(name) \
|
#define CHARACTER1(name) \
|
||||||
char * name; \
|
char * name; \
|
||||||
gfc_charlen_type name ## _len
|
gfc_charlen_type name ## _len
|
||||||
|
@ -247,6 +251,7 @@ st_parameter_common;
|
||||||
#define IOPARM_OPEN_HAS_ACTION (1 << 14)
|
#define IOPARM_OPEN_HAS_ACTION (1 << 14)
|
||||||
#define IOPARM_OPEN_HAS_DELIM (1 << 15)
|
#define IOPARM_OPEN_HAS_DELIM (1 << 15)
|
||||||
#define IOPARM_OPEN_HAS_PAD (1 << 16)
|
#define IOPARM_OPEN_HAS_PAD (1 << 16)
|
||||||
|
#define IOPARM_OPEN_HAS_CONVERT (1 << 17)
|
||||||
|
|
||||||
typedef struct
|
typedef struct
|
||||||
{
|
{
|
||||||
|
@ -261,6 +266,7 @@ typedef struct
|
||||||
CHARACTER2 (action);
|
CHARACTER2 (action);
|
||||||
CHARACTER1 (delim);
|
CHARACTER1 (delim);
|
||||||
CHARACTER2 (pad);
|
CHARACTER2 (pad);
|
||||||
|
CHARACTER1 (convert);
|
||||||
}
|
}
|
||||||
st_parameter_open;
|
st_parameter_open;
|
||||||
|
|
||||||
|
@ -301,6 +307,7 @@ st_parameter_filepos;
|
||||||
#define IOPARM_INQUIRE_HAS_READ (1 << 26)
|
#define IOPARM_INQUIRE_HAS_READ (1 << 26)
|
||||||
#define IOPARM_INQUIRE_HAS_WRITE (1 << 27)
|
#define IOPARM_INQUIRE_HAS_WRITE (1 << 27)
|
||||||
#define IOPARM_INQUIRE_HAS_READWRITE (1 << 28)
|
#define IOPARM_INQUIRE_HAS_READWRITE (1 << 28)
|
||||||
|
#define IOPARM_INQUIRE_HAS_CONVERT (1 << 29)
|
||||||
|
|
||||||
typedef struct
|
typedef struct
|
||||||
{
|
{
|
||||||
|
@ -323,6 +330,7 @@ typedef struct
|
||||||
CHARACTER2 (read);
|
CHARACTER2 (read);
|
||||||
CHARACTER1 (write);
|
CHARACTER1 (write);
|
||||||
CHARACTER2 (readwrite);
|
CHARACTER2 (readwrite);
|
||||||
|
CHARACTER1 (convert);
|
||||||
}
|
}
|
||||||
st_parameter_inquire;
|
st_parameter_inquire;
|
||||||
|
|
||||||
|
@ -419,7 +427,7 @@ typedef struct st_parameter_dt
|
||||||
kind. */
|
kind. */
|
||||||
char value[32];
|
char value[32];
|
||||||
} p;
|
} p;
|
||||||
char pad[16 * sizeof (char *) + 32 * sizeof (int)];
|
char pad[16 * sizeof (char *) + 34 * sizeof (int)];
|
||||||
} u;
|
} u;
|
||||||
}
|
}
|
||||||
st_parameter_dt;
|
st_parameter_dt;
|
||||||
|
@ -438,6 +446,7 @@ typedef struct
|
||||||
unit_position position;
|
unit_position position;
|
||||||
unit_status status;
|
unit_status status;
|
||||||
unit_pad pad;
|
unit_pad pad;
|
||||||
|
unit_convert convert;
|
||||||
}
|
}
|
||||||
unit_flags;
|
unit_flags;
|
||||||
|
|
||||||
|
@ -738,6 +747,9 @@ internal_proto(init_loop_spec);
|
||||||
extern void next_record (st_parameter_dt *, int);
|
extern void next_record (st_parameter_dt *, int);
|
||||||
internal_proto(next_record);
|
internal_proto(next_record);
|
||||||
|
|
||||||
|
extern void reverse_memcpy (void *, const void *, size_t);
|
||||||
|
internal_proto (reverse_memcpy);
|
||||||
|
|
||||||
/* read.c */
|
/* read.c */
|
||||||
|
|
||||||
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
|
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
|
||||||
|
|
|
@ -98,6 +98,14 @@ static const st_option pad_opt[] =
|
||||||
{ NULL, 0}
|
{ NULL, 0}
|
||||||
};
|
};
|
||||||
|
|
||||||
|
static const st_option convert_opt[] =
|
||||||
|
{
|
||||||
|
{ "native", CONVERT_NATIVE},
|
||||||
|
{ "swap", CONVERT_SWAP},
|
||||||
|
{ "big_endian", CONVERT_BIG},
|
||||||
|
{ "little_endian", CONVERT_LITTLE},
|
||||||
|
{ NULL, 0}
|
||||||
|
};
|
||||||
|
|
||||||
/* Given a unit, test to see if the file is positioned at the terminal
|
/* Given a unit, test to see if the file is positioned at the terminal
|
||||||
point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
|
point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
|
||||||
|
@ -531,6 +539,36 @@ st_open (st_parameter_open *opp)
|
||||||
find_option (&opp->common, opp->status, opp->status_len,
|
find_option (&opp->common, opp->status, opp->status_len,
|
||||||
status_opt, "Bad STATUS parameter in OPEN statement");
|
status_opt, "Bad STATUS parameter in OPEN statement");
|
||||||
|
|
||||||
|
if (cf & IOPARM_OPEN_HAS_CONVERT)
|
||||||
|
{
|
||||||
|
unit_convert conv;
|
||||||
|
conv = find_option (&opp->common, opp->convert, opp->convert_len,
|
||||||
|
convert_opt, "Bad CONVERT parameter in OPEN statement");
|
||||||
|
/* We use l8_to_l4_offset, which is 0 on little-endian machines
|
||||||
|
and 1 on big-endian machines. */
|
||||||
|
switch (conv)
|
||||||
|
{
|
||||||
|
case CONVERT_NATIVE:
|
||||||
|
case CONVERT_SWAP:
|
||||||
|
break;
|
||||||
|
|
||||||
|
case CONVERT_BIG:
|
||||||
|
conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
|
||||||
|
break;
|
||||||
|
|
||||||
|
case CONVERT_LITTLE:
|
||||||
|
conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
|
||||||
|
break;
|
||||||
|
|
||||||
|
default:
|
||||||
|
internal_error (&opp->common, "Illegal value for CONVERT");
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
flags.convert = conv;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
flags.convert = CONVERT_NATIVE;
|
||||||
|
|
||||||
if (opp->common.unit < 0)
|
if (opp->common.unit < 0)
|
||||||
generate_error (&opp->common, ERROR_BAD_OPTION,
|
generate_error (&opp->common, ERROR_BAD_OPTION,
|
||||||
"Bad unit number in OPEN statement");
|
"Bad unit number in OPEN statement");
|
||||||
|
|
|
@ -399,26 +399,89 @@ write_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
|
||||||
/* Master function for unformatted reads. */
|
/* Master function for unformatted reads. */
|
||||||
|
|
||||||
static void
|
static void
|
||||||
unformatted_read (st_parameter_dt *dtp, bt type __attribute__((unused)),
|
unformatted_read (st_parameter_dt *dtp, bt type,
|
||||||
void *dest, int kind __attribute__((unused)),
|
void *dest, int kind,
|
||||||
size_t size, size_t nelems)
|
size_t size, size_t nelems)
|
||||||
{
|
{
|
||||||
size *= nelems;
|
/* Currently, character implies size=1. */
|
||||||
|
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
|
||||||
read_block_direct (dtp, dest, &size);
|
|| size == 1 || type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
size *= nelems;
|
||||||
|
read_block_direct (dtp, dest, &size);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
char buffer[16];
|
||||||
|
char *p;
|
||||||
|
size_t i, sz;
|
||||||
|
|
||||||
|
/* Break up complex into its constituent reals. */
|
||||||
|
if (type == BT_COMPLEX)
|
||||||
|
{
|
||||||
|
nelems *= 2;
|
||||||
|
size /= 2;
|
||||||
|
}
|
||||||
|
p = dest;
|
||||||
|
|
||||||
|
/* By now, all complex variables have been split into their
|
||||||
|
constituent reals. For types with padding, we only need to
|
||||||
|
read kind bytes. We don't care about the contents
|
||||||
|
of the padding. */
|
||||||
|
|
||||||
|
sz = kind;
|
||||||
|
for (i=0; i<nelems; i++)
|
||||||
|
{
|
||||||
|
read_block_direct (dtp, buffer, &sz);
|
||||||
|
reverse_memcpy (p, buffer, sz);
|
||||||
|
p += size;
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
/* Master function for unformatted writes. */
|
/* Master function for unformatted writes. */
|
||||||
|
|
||||||
static void
|
static void
|
||||||
unformatted_write (st_parameter_dt *dtp, bt type __attribute__((unused)),
|
unformatted_write (st_parameter_dt *dtp, bt type,
|
||||||
void *source, int kind __attribute__((unused)),
|
void *source, int kind,
|
||||||
size_t size, size_t nelems)
|
size_t size, size_t nelems)
|
||||||
{
|
{
|
||||||
size *= nelems;
|
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
|
||||||
|
size == 1 || type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
size *= nelems;
|
||||||
|
|
||||||
write_block_direct (dtp, source, &size);
|
write_block_direct (dtp, source, &size);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
char buffer[16];
|
||||||
|
char *p;
|
||||||
|
size_t i, sz;
|
||||||
|
|
||||||
|
/* Break up complex into its constituent reals. */
|
||||||
|
if (type == BT_COMPLEX)
|
||||||
|
{
|
||||||
|
nelems *= 2;
|
||||||
|
size /= 2;
|
||||||
|
}
|
||||||
|
|
||||||
|
p = source;
|
||||||
|
|
||||||
|
/* By now, all complex variables have been split into their
|
||||||
|
constituent reals. For types with padding, we only need to
|
||||||
|
read kind bytes. We don't care about the contents
|
||||||
|
of the padding. */
|
||||||
|
|
||||||
|
sz = kind;
|
||||||
|
for (i=0; i<nelems; i++)
|
||||||
|
{
|
||||||
|
reverse_memcpy(buffer, p, size);
|
||||||
|
p+= size;
|
||||||
|
write_block_direct (dtp, buffer, &sz);
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -1154,7 +1217,12 @@ us_read (st_parameter_dt *dtp)
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
memcpy (&i, p, sizeof (gfc_offset));
|
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
|
||||||
|
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
|
||||||
|
memcpy (&i, p, sizeof (gfc_offset));
|
||||||
|
else
|
||||||
|
reverse_memcpy (&i, p, sizeof (gfc_offset));
|
||||||
|
|
||||||
dtp->u.p.current_unit->bytes_left = i;
|
dtp->u.p.current_unit->bytes_left = i;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1722,7 +1790,12 @@ next_record_w (st_parameter_dt *dtp)
|
||||||
if (p == NULL)
|
if (p == NULL)
|
||||||
goto io_error;
|
goto io_error;
|
||||||
|
|
||||||
memcpy (p, &m, sizeof (gfc_offset));
|
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
|
||||||
|
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
|
||||||
|
memcpy (p, &m, sizeof (gfc_offset));
|
||||||
|
else
|
||||||
|
reverse_memcpy (p, &m, sizeof (gfc_offset));
|
||||||
|
|
||||||
if (sfree (dtp->u.p.current_unit->s) == FAILURE)
|
if (sfree (dtp->u.p.current_unit->s) == FAILURE)
|
||||||
goto io_error;
|
goto io_error;
|
||||||
|
|
||||||
|
@ -1733,7 +1806,12 @@ next_record_w (st_parameter_dt *dtp)
|
||||||
if (p == NULL)
|
if (p == NULL)
|
||||||
generate_error (&dtp->common, ERROR_OS, NULL);
|
generate_error (&dtp->common, ERROR_OS, NULL);
|
||||||
|
|
||||||
memcpy (p, &m, sizeof (gfc_offset));
|
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
|
||||||
|
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
|
||||||
|
memcpy (p, &m, sizeof (gfc_offset));
|
||||||
|
else
|
||||||
|
reverse_memcpy (p, &m, sizeof (gfc_offset));
|
||||||
|
|
||||||
if (sfree (dtp->u.p.current_unit->s) == FAILURE)
|
if (sfree (dtp->u.p.current_unit->s) == FAILURE)
|
||||||
goto io_error;
|
goto io_error;
|
||||||
|
|
||||||
|
@ -2161,3 +2239,19 @@ st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
|
||||||
nml->dim[n].lbound = (ssize_t)lbound;
|
nml->dim[n].lbound = (ssize_t)lbound;
|
||||||
nml->dim[n].ubound = (ssize_t)ubound;
|
nml->dim[n].ubound = (ssize_t)ubound;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Reverse memcpy - used for byte swapping. */
|
||||||
|
|
||||||
|
void reverse_memcpy (void *dest, const void *src, size_t n)
|
||||||
|
{
|
||||||
|
char *d, *s;
|
||||||
|
size_t i;
|
||||||
|
|
||||||
|
d = (char *) dest;
|
||||||
|
s = (char *) src + n - 1;
|
||||||
|
|
||||||
|
/* Write with ascending order - this is likely faster
|
||||||
|
on modern architectures because of write combining. */
|
||||||
|
for (i=0; i<n; i++)
|
||||||
|
*(d++) = *(s--);
|
||||||
|
}
|
||||||
|
|
Loading…
Reference in New Issue