mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-01-25 09:44:14 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/37498 (Incorrect array value returned - 4.3 ABI Broken)

Browse Source 
2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org

	PR fortran/37498
	* trans-io.c (gfc_build_io_library_fndecls): Bump pad size.
	(build_dt): Set mask bit for IOPARM_dt_f2003.
	* ioparm.def: Add IOPARM_dt_f2003.

2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org

	PR libfortran/37498
	* file_pos (st_endfile): Clear memory only for libfortran 4.3 private
	area.
	* list_read.c (eat_separator): Only access F2003 I/O parameters if
	IOPARM_DT_HAS_F2003 bit is set. (parse_real): Ditto.
	(read_real): Ditto.
	* read.c (read_a): Likewise. (read_a_char4): Likewise though not
	strictly necessary. (read_f): Likewise.
	* io.h (unit_sign_s): New enumerator to allow duplication of
	st_parameter structures. (IOPARM_DT_HAS_F2003): New mask bit.
	(st_parameter_43): New structure copied from 4.3 version of 
	st_paramater_dt private section. (st_parameter_44): New structure with
	F2003 items added. (st_parameter_dt): Modified to create union of new
	and old structures to allow correct memory setting for 4.3 ABI
	compatibility. Bumped the pad size.
	* transfer.c (read_sf): Do not use F2003 I/O memory areas unless
	IOPARM_DT_HAS_F2003 bit has been set. (read_block_form): Ditto.
	(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto and
	add comment, fix formatting.
	* write.c (write_default_char4): Likewise though not strictly necessary.
	(write_utf8_char4): Ditto. (write_character): Ditto.
	(write_real_g0): Ditto. (list_formatted_write_scalar): Ditto.
	(nml_write_obj): Ditto. (namelist_write): Ditto.
	* write_float.def (calculate_sign): Eliminate warning by including all
	cases in switch. (output_float): Output only decimal point of F2003 flag
	is not set.

From-SVN: r140576
This commit is contained in:
Jerry DeLisle 2008-09-23 03:52:19 +00:00
parent 9992fbb571
commit d7445152be
11 changed files with 441 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2008-09-22 Jerry DeLisle <jvdelisle@gcc.gnu.org
PR fortran/37498
* trans-io.c (gfc_build_io_library_fndecls): Bump pad size.
(build_dt): Set mask bit for IOPARM_dt_f2003.
* ioparm.def: Add IOPARM_dt_f2003.
2008-09-22 Janus Weil <janus@gcc.gnu.org>
PR fortran/37486

1
gcc/fortran/ioparm.def
View File

@ -93,3 +93,4 @@ IOPARM (dt, pad, 1 << 22, char1)
IOPARM (dt, round, 1 << 23, char2)
IOPARM (dt, sign, 1 << 24, char1)
IOPARM (dt, u, 0, pad)
#define IOPARM_dt_f2003 (1 << 25)

4
gcc/fortran/trans-io.c
View File

@ -291,7 +291,7 @@ gfc_build_io_library_fndecls (void)
= build_pointer_type (gfc_intio_type_node);
types[IOPARM_type_parray] = pchar_type_node;
types[IOPARM_type_pchar] = pchar_type_node;
pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
pad_size = 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
@ -1641,7 +1641,7 @@ build_dt (tree function, gfc_code * code)
tree tmp, var;
gfc_expr *nmlname;
gfc_namelist *nml;
unsigned int mask = 0;
unsigned int mask = IOPARM_dt_f2003;
gfc_start_block (&block);
gfc_init_block (&post_block);

29
libgfortran/ChangeLog
View File

@ -1,3 +1,32 @@
2008-09-22 Jerry DeLisle <jvdelisle@gcc.gnu.org
PR libfortran/37498
* file_pos (st_endfile): Clear memory only for libfortran 4.3 private
area.
* list_read.c (eat_separator): Only access F2003 I/O parameters if
IOPARM_DT_HAS_F2003 bit is set. (parse_real): Ditto.
(read_real): Ditto.
* read.c (read_a): Likewise. (read_a_char4): Likewise though not
strictly necessary. (read_f): Likewise.
* io.h (unit_sign_s): New enumerator to allow duplication of
st_parameter structures. (IOPARM_DT_HAS_F2003): New mask bit.
(st_parameter_43): New structure copied from 4.3 version of
st_paramater_dt private section. (st_parameter_44): New structure with
F2003 items added. (st_parameter_dt): Modified to create union of new
and old structures to allow correct memory setting for 4.3 ABI
compatibility. Bumped the pad size.
* transfer.c (read_sf): Do not use F2003 I/O memory areas unless
IOPARM_DT_HAS_F2003 bit has been set. (read_block_form): Ditto.
(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto and
add comment, fix formatting.
* write.c (write_default_char4): Likewise though not strictly necessary.
(write_utf8_char4): Ditto. (write_character): Ditto.
(write_real_g0): Ditto. (list_formatted_write_scalar): Ditto.
(nml_write_obj): Ditto. (namelist_write): Ditto.
* write_float.def (calculate_sign): Eliminate warning by including all
cases in switch. (output_float): Output only decimal point of F2003 flag
is not set.
2008-09-10 Tobias Burnus <burnus@net-b.de>
H. J. Lu <hongjiu.lu@intel.com>

2
libgfortran/io/file_pos.c
View File

@ -300,7 +300,7 @@ st_endfile (st_parameter_filepos *fpp)
{
st_parameter_dt dtp;
dtp.common = fpp->common;
memset (&dtp.u.p, 0, sizeof (dtp.u.p));
memset (&dtp.u.p.transfer, 0, sizeof (dtp.u.q));
dtp.u.p.current_unit = u;
next_record (&dtp, 1);
}

273
libgfortran/io/io.h
View File

@ -233,6 +233,10 @@ typedef enum
{ ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
unit_async;
typedef enum
{ SIGN_S, SIGN_SS, SIGN_SP }
unit_sign_s;
#define CHARACTER1(name) \
char * name; \
gfc_charlen_type name ## _len
@ -368,9 +372,180 @@ struct format_data;
#define IOPARM_DT_HAS_PAD (1 << 22)
#define IOPARM_DT_HAS_ROUND (1 << 23)
#define IOPARM_DT_HAS_SIGN (1 << 24)
#define IOPARM_DT_HAS_F2003 (1 << 25)
/* Internal use bit. */
#define IOPARM_DT_IONML_SET (1 << 31)
typedef struct st_parameter_43
{
void (*transfer) (struct st_parameter_dt *, bt, void *, int,
size_t, size_t);
struct gfc_unit *current_unit;
/* Item number in a formatted data transfer. Also used in namelist
read_logical as an index into line_buffer. */
int item_count;
unit_mode mode;
unit_blank blank_status;
unit_sign sign_status;
int scale_factor;
int max_pos; /* Maximum righthand column written to. */
/* Number of skips + spaces to be done for T and X-editing. */
int skips;
/* Number of spaces to be done for T and X-editing. */
int pending_spaces;
/* Whether an EOR condition was encountered. Value is:
0 if no EOR was encountered
1 if an EOR was encountered due to a 1-byte marker (LF)
2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
int sf_seen_eor;
unit_advance advance_status;
unsigned reversion_flag : 1; /* Format reversion has occurred. */
unsigned first_item : 1;
unsigned seen_dollar : 1;
unsigned eor_condition : 1;
unsigned no_leading_blank : 1;
unsigned char_flag : 1;
unsigned input_complete : 1;
unsigned at_eol : 1;
unsigned comma_flag : 1;
/* A namelist specific flag used in the list directed library
to flag that calls are being made from namelist read (eg. to
ignore comments or to treat '/' as a terminator) */
unsigned namelist_mode : 1;
/* A namelist specific flag used in the list directed library
to flag read errors and return, so that an attempt can be
made to read a new object name. */
unsigned nml_read_error : 1;
/* A sequential formatted read specific flag used to signal that a
character string is being read so don't use commas to shorten a
formatted field width. */
unsigned sf_read_comma : 1;
/* A namelist specific flag used to enable reading input from
line_buffer for logical reads. */
unsigned line_buffer_enabled : 1;
/* An internal unit specific flag used to identify that the associated
unit is internal. */
unsigned unit_is_internal : 1;
/* An internal unit specific flag to signify an EOF condition for list
directed read. */
unsigned at_eof : 1;
/* 16 unused bits. */
char last_char;
char nml_delim;
int repeat_count;
int saved_length;
int saved_used;
bt saved_type;
char *saved_string;
char *scratch;
char *line_buffer;
struct format_data *fmt;
jmp_buf *eof_jump;
namelist_info *ionml;
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
int expanded_read;
/* Storage area for values except for strings. Must be large
enough to hold a complex value (two reals) of the largest
kind. */
char value[32];
gfc_offset size_used;
} st_parameter_43;
typedef struct st_parameter_44
{
GFC_IO_INT *id;
GFC_IO_INT pos;
CHARACTER1 (asynchronous);
CHARACTER2 (blank);
CHARACTER1 (decimal);
CHARACTER2 (delim);
CHARACTER1 (pad);
CHARACTER2 (round);
CHARACTER1 (sign);
void (*transfer) (struct st_parameter_dt *, bt, void *, int,
size_t, size_t);
struct gfc_unit *current_unit;
/* Item number in a formatted data transfer. Also used in namelist
read_logical as an index into line_buffer. */
int item_count;
unit_mode mode;
unit_blank blank_status;
unit_sign sign_status;
int scale_factor;
int max_pos; /* Maximum righthand column written to. */
/* Number of skips + spaces to be done for T and X-editing. */
int skips;
/* Number of spaces to be done for T and X-editing. */
int pending_spaces;
/* Whether an EOR condition was encountered. Value is:
0 if no EOR was encountered
1 if an EOR was encountered due to a 1-byte marker (LF)
2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
int sf_seen_eor;
unit_advance advance_status;
unsigned reversion_flag : 1; /* Format reversion has occurred. */
unsigned first_item : 1;
unsigned seen_dollar : 1;
unsigned eor_condition : 1;
unsigned no_leading_blank : 1;
unsigned char_flag : 1;
unsigned input_complete : 1;
unsigned at_eol : 1;
unsigned comma_flag : 1;
/* A namelist specific flag used in the list directed library
to flag that calls are being made from namelist read (eg. to
ignore comments or to treat '/' as a terminator) */
unsigned namelist_mode : 1;
/* A namelist specific flag used in the list directed library
to flag read errors and return, so that an attempt can be
made to read a new object name. */
unsigned nml_read_error : 1;
/* A sequential formatted read specific flag used to signal that a
character string is being read so don't use commas to shorten a
formatted field width. */
unsigned sf_read_comma : 1;
/* A namelist specific flag used to enable reading input from
line_buffer for logical reads. */
unsigned line_buffer_enabled : 1;
/* An internal unit specific flag used to identify that the associated
unit is internal. */
unsigned unit_is_internal : 1;
/* An internal unit specific flag to signify an EOF condition for list
directed read. */
unsigned at_eof : 1;
/* 16 unused bits. */
char last_char;
char nml_delim;
int repeat_count;
int saved_length;
int saved_used;
bt saved_type;
char *saved_string;
char *scratch;
char *line_buffer;
struct format_data *fmt;
jmp_buf *eof_jump;
namelist_info *ionml;
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
int expanded_read;
/* Storage area for values except for strings. Must be large
enough to hold a complex value (two reals) of the largest
kind. */
char value[32];
gfc_offset size_used;
unit_pad pad_status;
unit_decimal decimal_status;
unit_delim delim_status;
} st_parameter_44;
typedef struct st_parameter_dt
{
st_parameter_common common;
@ -381,104 +556,16 @@ typedef struct st_parameter_dt
CHARACTER2 (advance);
CHARACTER1 (internal_unit);
CHARACTER2 (namelist_name);
GFC_IO_INT *id;
GFC_IO_INT pos;
CHARACTER1 (asynchronous);
CHARACTER2 (blank);
CHARACTER1 (decimal);
CHARACTER2 (delim);
CHARACTER1 (pad);
CHARACTER2 (round);
CHARACTER1 (sign);
/* Private part of the structure. The compiler just needs
to reserve enough space. */
union
{
struct
{
void (*transfer) (struct st_parameter_dt *, bt, void *, int,
size_t, size_t);
struct gfc_unit *current_unit;
/* Item number in a formatted data transfer. Also used in namelist
read_logical as an index into line_buffer. */
int item_count;
unit_mode mode;
unit_blank blank_status;
unit_pad pad_status;
enum { SIGN_S, SIGN_SS, SIGN_SP } sign_status;
int scale_factor;
int max_pos; /* Maximum righthand column written to. */
/* Number of skips + spaces to be done for T and X-editing. */
int skips;
/* Number of spaces to be done for T and X-editing. */
int pending_spaces;
/* Whether an EOR condition was encountered. Value is:
0 if no EOR was encountered
1 if an EOR was encountered due to a 1-byte marker (LF)
2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
int sf_seen_eor;
unit_advance advance_status;
unit_decimal decimal_status;
unit_delim delim_status;
unsigned reversion_flag : 1; /* Format reversion has occurred. */
unsigned first_item : 1;
unsigned seen_dollar : 1;
unsigned eor_condition : 1;
unsigned no_leading_blank : 1;
unsigned char_flag : 1;
unsigned input_complete : 1;
unsigned at_eol : 1;
unsigned comma_flag : 1;
/* A namelist specific flag used in the list directed library
to flag that calls are being made from namelist read (eg. to
ignore comments or to treat '/' as a terminator) */
unsigned namelist_mode : 1;
/* A namelist specific flag used in the list directed library
to flag read errors and return, so that an attempt can be
made to read a new object name. */
unsigned nml_read_error : 1;
/* A sequential formatted read specific flag used to signal that a
character string is being read so don't use commas to shorten a
formatted field width. */
unsigned sf_read_comma : 1;
/* A namelist specific flag used to enable reading input from
line_buffer for logical reads. */
unsigned line_buffer_enabled : 1;
/* An internal unit specific flag used to identify that the associated
unit is internal. */
unsigned unit_is_internal : 1;
/* An internal unit specific flag to signify an EOF condition for list
directed read. */
unsigned at_eof : 1;
/* 16 unused bits. */
char last_char;
char nml_delim;
int repeat_count;
int saved_length;
int saved_used;
bt saved_type;
char *saved_string;
char *scratch;
char *line_buffer;
struct format_data *fmt;
jmp_buf *eof_jump;
namelist_info *ionml;
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
int expanded_read;
/* Storage area for values except for strings. Must be large
enough to hold a complex value (two reals) of the largest
kind. */
char value[32];
gfc_offset size_used;
} p;
st_parameter_43 q;
st_parameter_44 p;
/* This pad size must be equal to the pad_size declared in
trans-io.c (gfc_build_io_library_fndecls). The above structure
must be smaller or equal to this array. */
char pad[16 * sizeof (char *) + 32 * sizeof (int)];
char pad[32 * sizeof (char *) + 32 * sizeof (int)];
} u;
}
st_parameter_dt;
@ -512,12 +599,12 @@ typedef struct
unit_position position;
unit_status status;
unit_pad pad;
unit_convert convert;
int has_recl;
unit_decimal decimal;
unit_encoding encoding;
unit_round round;
unit_sign sign;
unit_convert convert;
int has_recl;
unit_async async;
}
unit_flags;

35
libgfortran/io/list_read.c
View File

@ -324,7 +324,8 @@ eat_separator (st_parameter_dt *dtp)
switch (c)
{
case ',':
if (dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& dtp->u.p.decimal_status == DECIMAL_COMMA)
{
unget_char (dtp, c);
break;
@ -1116,7 +1117,8 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
c = next_char (dtp);
}
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.')
@ -1134,7 +1136,8 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
for (;;)
{
c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
@ -1305,9 +1308,17 @@ eol_1:
else
unget_char (dtp, c);
if (next_char (dtp)
!= (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
{
if (next_char (dtp)
!= (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
}
else
{
if (next_char (dtp) != ',')
goto bad_complex;
}
eol_2:
eat_spaces (dtp);
@ -1360,7 +1371,8 @@ read_real (st_parameter_dt *dtp, int length)
seen_dp = 0;
c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
@ -1397,7 +1409,8 @@ read_real (st_parameter_dt *dtp, int length)
for (;;)
{
c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
@ -1463,7 +1476,8 @@ read_real (st_parameter_dt *dtp, int length)
c = next_char (dtp);
}
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.')
@ -1488,7 +1502,8 @@ read_real (st_parameter_dt *dtp, int length)
for (;;)
{
c = next_char (dtp);
if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{

33
libgfortran/io/read.c
View File

@ -439,9 +439,10 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
read_utf8_char1 (dtp, p, length, w);
else
read_default_char1 (dtp, p, length, w);
dtp->u.p.sf_read_comma =
dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.sf_read_comma = 1;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
}
@ -467,8 +468,9 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
else
read_default_char4 (dtp, p, length, w);
dtp->u.p.sf_read_comma =
dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.sf_read_comma = 1;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
}
/* eat_leading_spaces()-- Given a character pointer and a width,
@ -840,8 +842,11 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
switch (*p)
{
case ',':
if (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')
*p = '.';
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ','))
*p = '.';
else
goto bad_float;
/* Fall through */
case '.':
if (seen_dp)
@ -1074,9 +1079,17 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
void
read_x (st_parameter_dt * dtp, int n)
{
if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
{
if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
}
else
{
if (is_internal_unit (dtp) && dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
}
dtp->u.p.sf_read_comma = 0;
if (n > 0)

223
libgfortran/io/transfer.c
View File

@ -264,7 +264,8 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
so we can just continue with a short read. */
if (dtp->u.p.pad_status == PAD_NO)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& dtp->u.p.pad_status == PAD_NO)
{
if (no_error)
break;
@ -329,10 +330,11 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
to unit record length and proceed, otherwise error. */
if (dtp->u.p.current_unit->unit_number == options.stdin_unit
&& dtp->u.p.current_unit->recl == DEFAULT_RECL)
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
if (dtp->u.p.pad_status == PAD_NO)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& dtp->u.p.pad_status == PAD_NO)
{
/* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL);
@ -379,7 +381,8 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (nread != *nbytes)
{ /* Short read, this shouldn't happen. */
if (dtp->u.p.pad_status == PAD_YES)
if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
&& dtp->u.p.pad_status == PAD_YES)
*nbytes = nread;
else
{
@ -950,7 +953,11 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
/* Set this flag so that commas in reads cause the read to complete before
the entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.sf_read_comma = 1;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.line_buffer = scratch;
for (;;)
@ -1820,7 +1827,13 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
namelist_info *ionml;
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
/* To maintain ABI, &transfer is the start of the private memory area in
in st_parameter_dt. Memory from the beginning of the structure to this
point is set by the front end and must not be touched. The number of
bytes to clear must stay within the sizeof q to avoid over-writing. */
memset (&dtp->u.p.transfer, 0, sizeof (dtp->u.q));
dtp->u.p.ionml = ionml;
dtp->u.p.mode = read_flag ? READING : WRITING;
@ -1836,60 +1849,61 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
st_parameter_open opp;
unit_convert conv;
if (dtp->common.unit < 0)
{
close_unit (dtp->u.p.current_unit);
dtp->u.p.current_unit = NULL;
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
return;
}
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
if (dtp->common.unit < 0)
{
close_unit (dtp->u.p.current_unit);
dtp->u.p.current_unit = NULL;
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
return;
}
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
/* Is it unformatted? */
if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
| IOPARM_DT_IONML_SET)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
/* Is it unformatted? */
if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
| IOPARM_DT_IONML_SET)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.decimal = DECIMAL_UNSPECIFIED;
u_flags.encoding = ENCODING_UNSPECIFIED;
u_flags.async = ASYNC_UNSPECIFIED;
u_flags.round = ROUND_UNSPECIFIED;
u_flags.sign = SIGN_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.decimal = DECIMAL_UNSPECIFIED;
u_flags.encoding = ENCODING_UNSPECIFIED;
u_flags.async = ASYNC_UNSPECIFIED;
u_flags.round = ROUND_UNSPECIFIED;
u_flags.sign = SIGN_UNSPECIFIED;
conv = get_unformatted_convert (dtp->common.unit);
u_flags.status = STATUS_UNKNOWN;
if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert;
conv = get_unformatted_convert (dtp->common.unit);
/* We use big_endian, which is 0 on little-endian machines
and 1 on big-endian machines. */
switch (conv)
{
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert;
/* We use big_endian, which is 0 on little-endian machines
and 1 on big-endian machines. */
switch (conv)
{
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
}
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
}
u_flags.convert = conv;
@ -1970,7 +1984,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
&& (cf & IOPARM_DT_HAS_REC) != 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Record number not allowed for sequential access data transfer");
"Record number not allowed for sequential access "
"data transfer");
return;
}
@ -1986,7 +2001,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with sequential access");
"ADVANCE specification conflicts with sequential "
"access");
return;
}
@ -2018,10 +2034,12 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
"SIZE specification requires an ADVANCE specification of NO");
"SIZE specification requires an ADVANCE "
"specification of NO");
return;
}
}
@ -2030,21 +2048,24 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if ((cf & IOPARM_END) != 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"END specification cannot appear in a write statement");
"END specification cannot appear in a write "
"statement");
return;
}
if ((cf & IOPARM_EOR) != 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"EOR specification cannot appear in a write statement");
"EOR specification cannot appear in a write "
"statement");
return;
}
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"SIZE specification cannot appear in a write statement");
"SIZE specification cannot appear in a write "
"statement");
return;
}
}
@ -2052,52 +2073,58 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES;
/* Check the decimal mode. */
/* To maintain ABI check these only if we have the F2003 flag set. */
if(cf & IOPARM_DT_HAS_F2003)
{
/* Check the decimal mode. */
dtp->u.p.decimal_status
= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
decimal_opt, "Bad DECIMAL parameter in data transfer "
"statement");
dtp->u.p.decimal_status
= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&dtp->common, dtp->decimal, dtp->decimal_len, decimal_opt,
"Bad DECIMAL parameter in data transfer statement");
if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
/* Check the sign mode. */
dtp->u.p.sign_status
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
/* Check the sign mode. */
dtp->u.p.sign_status
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
/* Check the blank mode. */
dtp->u.p.blank_status
= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
/* Check the delim mode. */
dtp->u.p.delim_status
= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
delim_opt,
"Bad DELIM parameter in data transfer statement");
if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
/* Check the blank mode. */
dtp->u.p.blank_status
= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt,
"Bad BLANK parameter in data transfer statement");
/* Check the pad mode. */
dtp->u.p.pad_status
= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
"Bad PAD parameter in data transfer statement");
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
/* Check the delim mode. */
dtp->u.p.delim_status
= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&dtp->common, dtp->delim, dtp->delim_len, delim_opt,
"Bad DELIM parameter in data transfer statement");
if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
}
/* Check the pad mode. */
dtp->u.p.pad_status
= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
"Bad PAD parameter in data transfer statement");
if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{

61
libgfortran/io/write.c
View File

@ -65,7 +65,8 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
}
/* Get ready to handle delimiters if needed. */
d = ' ';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{
case DELIM_APOSTROPHE:
@ -128,7 +129,8 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
}
/* Get ready to handle delimiters if needed. */
d = ' ';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{
case DELIM_APOSTROPHE:
@ -880,6 +882,8 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
int i, extra;
char *p, d;
d = ' ';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{
case DELIM_APOSTROPHE:
@ -1018,7 +1022,10 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
char semi_comma = ',';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
if (write_char (dtp, '('))
return;
@ -1065,9 +1072,17 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
}
else
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
dtp->u.p.delim_status != DELIM_NONE)
write_separator (dtp);
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
dtp->u.p.delim_status != DELIM_NONE)
write_separator (dtp);
}
else
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag)
write_separator (dtp);
}
}
switch (type)
@ -1182,7 +1197,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
/* Set the character to be used to separate values
to a comma or semi-colon. */
char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
char semi_comma = ',';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
@ -1297,13 +1315,18 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break;
case GFC_DTYPE_CHARACTER:
tmp_delim = dtp->u.p.delim_status;
if (dtp->u.p.nml_delim == '"')
dtp->u.p.delim_status = DELIM_QUOTE;
if (dtp->u.p.nml_delim == '\'')
dtp->u.p.delim_status = DELIM_APOSTROPHE;
write_character (dtp, p, 1, obj->string_length);
dtp->u.p.delim_status = tmp_delim;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
{
tmp_delim = dtp->u.p.delim_status;
if (dtp->u.p.nml_delim == '"')
dtp->u.p.delim_status = DELIM_QUOTE;
if (dtp->u.p.nml_delim == '\'')
dtp->u.p.delim_status = DELIM_APOSTROPHE;
write_character (dtp, p, 1, obj->string_length);
dtp->u.p.delim_status = tmp_delim;
}
else
write_character (dtp, p, 1, obj->string_length);
break;
case GFC_DTYPE_REAL:
@ -1438,10 +1461,11 @@ namelist_write (st_parameter_dt *dtp)
index_type dummy_offset = 0;
char c;
char * dummy_name = NULL;
unit_delim tmp_delim;
unit_delim tmp_delim = DELIM_UNSPECIFIED;
/* Set the delimiter for namelist output. */
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
{
tmp_delim = dtp->u.p.delim_status;
switch (tmp_delim)
{
@ -1460,7 +1484,7 @@ namelist_write (st_parameter_dt *dtp)
/* Temporarily disable namelist delimters. */
dtp->u.p.delim_status = DELIM_NONE;
}
write_character (dtp, "&", 1, 1);
/* Write namelist name in upper case - f95 std. */
@ -1483,7 +1507,8 @@ namelist_write (st_parameter_dt *dtp)
write_character (dtp, " /", 1, 3);
namelist_write_newline (dtp);
/* Restore the original delimiter. */
dtp->u.p.delim_status = tmp_delim;
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
dtp->u.p.delim_status = tmp_delim;
}
#undef NML_DIGITS

6
libgfortran/io/write_float.def
View File

@ -55,6 +55,7 @@ calculate_sign (st_parameter_dt *dtp, int negative_flag)
s = S_NONE;
break;
case SIGN_S: /* Processor defined. */
case SIGN_UNSPECIFIED:
s = options.optional_plus ? S_PLUS : S_NONE;
break;
}
@ -403,7 +404,10 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
out += nbefore;
}
/* Output the decimal point. */
*(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
*(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
else
*(out++) = '.';
/* Output leading zeros after the decimal point. */
if (nzero > 0)