This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, fortran] [4.4 Regression] PR37498 Incorrect array value returned - 4.3 ABI Broken - FINAL
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 21 Sep 2008 12:48:26 -0700
- Subject: [patch, fortran] [4.4 Regression] PR37498 Incorrect array value returned - 4.3 ABI Broken - FINAL
Hi All,
The attached patch has been cleaned up from the previous and regression tested
on x86-64. Regression testing on ppc64-linux is in progress and looks good so far.
I added checks to avoid accessing the F2003 I/O parameters by a 4.3 compiled
program.
I have not a way to cross test 4.3 compiled testsuite with 4.4 libgfortran.
Suggestions would be appreciated.
OK to commit to trunk?
Regards,
Jerry
2008-09-21 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-21 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.
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 140515)
+++ gcc/fortran/trans-io.c (working copy)
@@ -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);
Index: gcc/fortran/ioparm.def
===================================================================
--- gcc/fortran/ioparm.def (revision 140515)
+++ gcc/fortran/ioparm.def (working copy)
@@ -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)
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (revision 140515)
+++ libgfortran/io/file_pos.c (working copy)
@@ -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);
}
Index: libgfortran/io/list_read.c
===================================================================
--- libgfortran/io/list_read.c (revision 140515)
+++ libgfortran/io/list_read.c (working copy)
@@ -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 *
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 *
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 len
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 len
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 len
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 len
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)
{
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 140515)
+++ libgfortran/io/read.c (working copy)
@@ -439,9 +439,10 @@ read_a (st_parameter_dt *dtp, const fnod
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, cons
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 fnod
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 fnod
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)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 140515)
+++ libgfortran/io/io.h (working copy)
@@ -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,19 +372,92 @@ 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_dt
+
+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
{
- st_parameter_common common;
- GFC_IO_INT rec;
- GFC_IO_INT *size, *iolength;
- gfc_array_char *internal_unit_desc;
- CHARACTER1 (format);
- CHARACTER2 (advance);
- CHARACTER1 (internal_unit);
- CHARACTER2 (namelist_name);
GFC_IO_INT *id;
GFC_IO_INT pos;
CHARACTER1 (asynchronous);
@@ -390,95 +467,105 @@ typedef struct st_parameter_dt
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;
+ GFC_IO_INT rec;
+ GFC_IO_INT *size, *iolength;
+ gfc_array_char *internal_unit_desc;
+ CHARACTER1 (format);
+ CHARACTER2 (advance);
+ CHARACTER1 (internal_unit);
+ CHARACTER2 (namelist_name);
/* 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;
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 140515)
+++ libgfortran/io/transfer.c (working copy)
@@ -264,7 +264,8 @@ read_sf (st_parameter_dt *dtp, int *leng
/* 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, v
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, v
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_
/* 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
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
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;
-
- /* 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;
-
- conv = get_unformatted_convert (dtp->common.unit);
-
- 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;
+ 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;
+
+ 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;
+
+ conv = get_unformatted_convert (dtp->common.unit);
+
+ 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
&& (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
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
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
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
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES;
- /* Check the decimal mode. */
-
- 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;
-
- /* 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");
+ /* 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");
+
+ 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;
+ if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
+ dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
- /* 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 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.blank_status == BLANK_UNSPECIFIED)
- dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+ 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");
+ /* 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;
+ if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
+ dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
- /* 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");
+ /* 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.pad_status == PAD_UNSPECIFIED)
- dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
-
+ 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)
{
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c (revision 140515)
+++ libgfortran/io/write.c (working copy)
@@ -65,7 +65,8 @@ write_default_char4 (st_parameter_dt *dt
}
/* 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,
}
/* 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, c
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, con
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_paramete
}
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, nam
/* 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, nam
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
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def (revision 140515)
+++ libgfortran/io/write_float.def (working copy)
@@ -55,6 +55,7 @@ calculate_sign (st_parameter_dt *dtp, in
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, cons
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)