Skip to content

R
riscv-gcc-1
Commit 105b7136 by Jerry DeLisle
Options

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

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

	PR libfortran/37498
	* list_read.c (eat_separator): Revert previous patch and move
	delim_status, decimal_status, and pad_status to gfc_unit.
	(parse_real): Ditto. (read_real): Ditto.
	* read.c (read_a): Likewise. (read_a_char4): Likewise.
	(read_f): Likewise.
	* inquire.c (inquire_via_unit): Add missing check for
	IOPARM_INQUIRE_HAS_FLAGS2. (inquire_via_filename): Likewise.
	* io.h (unit_sign_s): Move delim_status, decimal_status, and pad_status
	to gfc_unit.
	* transfer.c (read_sf): Ditto. (read_block_form): Ditto.
	(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto.
	* write.c (write_default_char4): Ditto. (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): Ditto. (output_float): Ditto.

From-SVN: r140684
parent 5e1bdeb7
Showing with 228 additions and 266 deletions
libgfortran/ChangeLog
2008-09-25 Jerry DeLisle <jvdelisle@gcc.gnu.org
PR libfortran/37498
* list_read.c (eat_separator): Revert previous patch and move
delim_status, decimal_status, and pad_status to gfc_unit.
(parse_real): Ditto. (read_real): Ditto.
* read.c (read_a): Likewise. (read_a_char4): Likewise.
(read_f): Likewise.
* inquire.c (inquire_via_unit): Add missing check for
IOPARM_INQUIRE_HAS_FLAGS2. (inquire_via_filename): Likewise.
* io.h (unit_sign_s): Move delim_status, decimal_status, and pad_status
to gfc_unit.
* transfer.c (read_sf): Ditto. (read_block_form): Ditto.
(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto.
* write.c (write_default_char4): Ditto. (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): Ditto. (output_float): Ditto.
2008-09-24 Tobias Burnus <burnus@net-b.de> 2008-09-24 Tobias Burnus <burnus@net-b.de>
* runtime/compile_options.c (init_compile_options): * runtime/compile_options.c (init_compile_options):
......
libgfortran/io/inquire.c
...@@ -252,125 +252,128 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) ...@@ -252,125 +252,128 @@ 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 ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
*iqp->pending = 0;
if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
*iqp->id = 0;
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
{ {
if (u == NULL || u->flags.form != FORM_FORMATTED) if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
p = undefined; *iqp->pending = 0;
else
switch (u->flags.encoding) if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
{ *iqp->id = 0;
case ENCODING_DEFAULT:
p = "UNKNOWN";
break;
case ENCODING_UTF8:
p = "UTF-8";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
}
cf_strcpy (iqp->encoding, iqp->encoding_len, p);
}
if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
else
switch (u->flags.decimal)
{
case DECIMAL_POINT:
p = "POINT";
break;
case DECIMAL_COMMA:
p = "COMMA";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
}
cf_strcpy (iqp->decimal, iqp->decimal_len, p);
}
if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
{
if (u == NULL)
p = undefined;
else
switch (u->flags.async)
{
case ASYNC_YES:
p = "YES";
break;
case ASYNC_NO:
p = "NO";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad async");
}
cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p); if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
} {
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
else
switch (u->flags.encoding)
{
case ENCODING_DEFAULT:
p = "UNKNOWN";
break;
case ENCODING_UTF8:
p = "UTF-8";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
}
cf_strcpy (iqp->encoding, iqp->encoding_len, p);
}
if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0) if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
{ {
if (u == NULL) if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined; p = undefined;
else else
switch (u->flags.sign) switch (u->flags.decimal)
{ {
case SIGN_PROCDEFINED: case DECIMAL_POINT:
p = "PROCESSOR_DEFINED"; p = "POINT";
break; break;
case SIGN_SUPPRESS: case DECIMAL_COMMA:
p = "SUPPRESS"; p = "COMMA";
break; break;
case SIGN_PLUS: default:
p = "PLUS"; internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
break; }
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad sign"); cf_strcpy (iqp->decimal, iqp->decimal_len, p);
} }
cf_strcpy (iqp->sign, iqp->sign_len, p); if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
} {
if (u == NULL)
p = undefined;
else
switch (u->flags.async)
{
case ASYNC_YES:
p = "YES";
break;
case ASYNC_NO:
p = "NO";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad async");
}
cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
}
if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0) if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
{ {
if (u == NULL) if (u == NULL)
p = undefined; p = undefined;
else else
switch (u->flags.round) switch (u->flags.sign)
{ {
case ROUND_UP: case SIGN_PROCDEFINED:
p = "UP"; p = "PROCESSOR_DEFINED";
break; break;
case ROUND_DOWN: case SIGN_SUPPRESS:
p = "DOWN"; p = "SUPPRESS";
break; break;
case ROUND_ZERO: case SIGN_PLUS:
p = "ZERO"; p = "PLUS";
break; break;
case ROUND_NEAREST: default:
p = "NEAREST"; internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
break; }
case ROUND_COMPATIBLE:
p = "COMPATIBLE"; cf_strcpy (iqp->sign, iqp->sign_len, p);
break; }
case ROUND_PROCDEFINED:
p = "PROCESSOR_DEFINED";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad round");
}
cf_strcpy (iqp->round, iqp->round_len, p); if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
{
if (u == NULL)
p = undefined;
else
switch (u->flags.round)
{
case ROUND_UP:
p = "UP";
break;
case ROUND_DOWN:
p = "DOWN";
break;
case ROUND_ZERO:
p = "ZERO";
break;
case ROUND_NEAREST:
p = "NEAREST";
break;
case ROUND_COMPATIBLE:
p = "COMPATIBLE";
break;
case ROUND_PROCDEFINED:
p = "PROCESSOR_DEFINED";
break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad round");
}
cf_strcpy (iqp->round, iqp->round_len, p);
}
} }
if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
...@@ -581,14 +584,26 @@ inquire_via_filename (st_parameter_inquire *iqp) ...@@ -581,14 +584,26 @@ inquire_via_filename (st_parameter_inquire *iqp)
if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
cf_strcpy (iqp->pad, iqp->pad_len, undefined); cf_strcpy (iqp->pad, iqp->pad_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
cf_strcpy (iqp->encoding, iqp->encoding_len, undefined); {
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0) if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
cf_strcpy (iqp->delim, iqp->delim_len, undefined); cf_strcpy (iqp->delim, iqp->delim_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0) if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
cf_strcpy (iqp->decimal, iqp->decimal_len, undefined); cf_strcpy (iqp->delim, iqp->delim_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
cf_strcpy (iqp->pad, iqp->pad_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
}
if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
cf_strcpy (iqp->position, iqp->position_len, undefined); cf_strcpy (iqp->position, iqp->position_len, undefined);
...@@ -613,15 +628,6 @@ inquire_via_filename (st_parameter_inquire *iqp) ...@@ -613,15 +628,6 @@ inquire_via_filename (st_parameter_inquire *iqp)
p = inquire_read (iqp->file, iqp->file_len); p = inquire_read (iqp->file, iqp->file_len);
cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
} }
if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
cf_strcpy (iqp->delim, iqp->delim_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
cf_strcpy (iqp->pad, iqp->pad_len, undefined);
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
} }
......
libgfortran/io/io.h
...@@ -541,9 +541,6 @@ typedef struct st_parameter_44 ...@@ -541,9 +541,6 @@ typedef struct st_parameter_44
kind. */ kind. */
char value[32]; char value[32];
gfc_offset size_used; gfc_offset size_used;
unit_pad pad_status;
unit_decimal decimal_status;
unit_delim delim_status;
} st_parameter_44; } st_parameter_44;
typedef struct st_parameter_dt typedef struct st_parameter_dt
...@@ -646,6 +643,9 @@ typedef struct gfc_unit ...@@ -646,6 +643,9 @@ typedef struct gfc_unit
unit_mode mode; unit_mode mode;
unit_flags flags; unit_flags flags;
unit_pad pad_status;
unit_decimal decimal_status;
unit_delim delim_status;
/* recl -- Record length of the file. /* recl -- Record length of the file.
last_record -- Last record number read or written last_record -- Last record number read or written
......
libgfortran/io/list_read.c
...@@ -324,8 +324,7 @@ eat_separator (st_parameter_dt *dtp) ...@@ -324,8 +324,7 @@ eat_separator (st_parameter_dt *dtp)
switch (c) switch (c)
{ {
case ',': case ',':
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& dtp->u.p.decimal_status == DECIMAL_COMMA)
{ {
unget_char (dtp, c); unget_char (dtp, c);
break; break;
...@@ -935,8 +934,8 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) ...@@ -935,8 +934,8 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
default: default:
if (dtp->u.p.namelist_mode) if (dtp->u.p.namelist_mode)
{ {
if (dtp->u.p.delim_status == DELIM_APOSTROPHE if (dtp->u.p.current_unit->delim_status == DELIM_APOSTROPHE
|| dtp->u.p.delim_status == DELIM_QUOTE || dtp->u.p.current_unit->delim_status == DELIM_QUOTE
|| c == '&' || c == '$' || c == '/') || c == '&' || c == '$' || c == '/')
{ {
unget_char (dtp, c); unget_char (dtp, c);
...@@ -1117,8 +1116,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) ...@@ -1117,8 +1116,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
c = next_char (dtp); c = next_char (dtp);
} }
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
if (!isdigit (c) && c != '.') if (!isdigit (c) && c != '.')
...@@ -1136,8 +1134,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) ...@@ -1136,8 +1134,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
switch (c) switch (c)
{ {
...@@ -1308,17 +1305,9 @@ eol_1: ...@@ -1308,17 +1305,9 @@ eol_1:
else else
unget_char (dtp, c); unget_char (dtp, c);
if (dtp->common.flags & IOPARM_DT_HAS_F2003) if (next_char (dtp)
{ != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
if (next_char (dtp) goto bad_complex;
!= (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
}
else
{
if (next_char (dtp) != ',')
goto bad_complex;
}
eol_2: eol_2:
eat_spaces (dtp); eat_spaces (dtp);
...@@ -1371,8 +1360,7 @@ read_real (st_parameter_dt *dtp, int length) ...@@ -1371,8 +1360,7 @@ read_real (st_parameter_dt *dtp, int length)
seen_dp = 0; seen_dp = 0;
c = next_char (dtp); c = next_char (dtp);
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
switch (c) switch (c)
{ {
...@@ -1409,8 +1397,7 @@ read_real (st_parameter_dt *dtp, int length) ...@@ -1409,8 +1397,7 @@ read_real (st_parameter_dt *dtp, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
switch (c) switch (c)
{ {
...@@ -1476,8 +1463,7 @@ read_real (st_parameter_dt *dtp, int length) ...@@ -1476,8 +1463,7 @@ read_real (st_parameter_dt *dtp, int length)
c = next_char (dtp); c = next_char (dtp);
} }
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
if (!isdigit (c) && c != '.') if (!isdigit (c) && c != '.')
...@@ -1502,8 +1488,7 @@ read_real (st_parameter_dt *dtp, int length) ...@@ -1502,8 +1488,7 @@ read_real (st_parameter_dt *dtp, int length)
for (;;) for (;;)
{ {
c = next_char (dtp); c = next_char (dtp);
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
&& c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
c = '.'; c = '.';
switch (c) switch (c)
{ {
......
libgfortran/io/read.c
...@@ -440,9 +440,8 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length) ...@@ -440,9 +440,8 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
else else
read_default_char1 (dtp, p, length, w); read_default_char1 (dtp, p, length, w);
dtp->u.p.sf_read_comma = 1; dtp->u.p.sf_read_comma =
if (dtp->common.flags & IOPARM_DT_HAS_F2003) dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
} }
...@@ -468,9 +467,8 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length) ...@@ -468,9 +467,8 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
else else
read_default_char4 (dtp, p, length, w); read_default_char4 (dtp, p, length, w);
dtp->u.p.sf_read_comma = 1; dtp->u.p.sf_read_comma =
if (dtp->common.flags & IOPARM_DT_HAS_F2003) dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
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, /* eat_leading_spaces()-- Given a character pointer and a width,
...@@ -842,9 +840,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) ...@@ -842,9 +840,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
switch (*p) switch (*p)
{ {
case ',': case ',':
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
&& (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')) && *p == ',')
*p = '.'; *p = '.';
else else
goto bad_float; goto bad_float;
/* Fall through */ /* Fall through */
...@@ -1079,17 +1077,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) ...@@ -1079,17 +1077,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
void void
read_x (st_parameter_dt * dtp, int n) read_x (st_parameter_dt * dtp, int n)
{ {
if (dtp->common.flags & IOPARM_DT_HAS_F2003) if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
{ && dtp->u.p.current_unit->bytes_left < n)
if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp)) n = dtp->u.p.current_unit->bytes_left;
&& 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; dtp->u.p.sf_read_comma = 0;
if (n > 0) if (n > 0)
......
libgfortran/io/transfer.c
...@@ -264,8 +264,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) ...@@ -264,8 +264,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
/* Without padding, terminate the I/O statement without assigning /* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned, the value. With padding, the value still needs to be assigned,
so we can just continue with a short read. */ so we can just continue with a short read. */
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (dtp->u.p.current_unit->pad_status == PAD_NO)
&& dtp->u.p.pad_status == PAD_NO)
{ {
if (no_error) if (no_error)
break; break;
...@@ -333,8 +332,7 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) ...@@ -333,8 +332,7 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
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 else
{ {
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (dtp->u.p.current_unit->pad_status == PAD_NO)
&& dtp->u.p.pad_status == PAD_NO)
{ {
/* Not enough data left. */ /* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
...@@ -381,8 +379,7 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) ...@@ -381,8 +379,7 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (nread != *nbytes) if (nread != *nbytes)
{ /* Short read, this shouldn't happen. */ { /* Short read, this shouldn't happen. */
if ((dtp->common.flags & IOPARM_DT_HAS_F2003) if (dtp->u.p.current_unit->pad_status == PAD_YES)
&& dtp->u.p.pad_status == PAD_YES)
*nbytes = nread; *nbytes = nread;
else else
{ {
...@@ -953,10 +950,8 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, ...@@ -953,10 +950,8 @@ 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 /* 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 entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */ the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma = 1; dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 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; dtp->u.p.line_buffer = scratch;
...@@ -1375,12 +1370,12 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, ...@@ -1375,12 +1370,12 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
case FMT_DC: case FMT_DC:
consume_data_flag = 0; consume_data_flag = 0;
dtp->u.p.decimal_status = DECIMAL_COMMA; dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
break; break;
case FMT_DP: case FMT_DP:
consume_data_flag = 0; consume_data_flag = 0;
dtp->u.p.decimal_status = DECIMAL_POINT; dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break; break;
case FMT_P: case FMT_P:
...@@ -2073,57 +2068,52 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) ...@@ -2073,57 +2068,52 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES; dtp->u.p.advance_status = ADVANCE_YES;
/* To maintain ABI check these only if we have the F2003 flag set. */ /* Check the decimal mode. */
if(cf & IOPARM_DT_HAS_F2003) dtp->u.p.current_unit->decimal_status
{
/* Check the decimal mode. */
dtp->u.p.decimal_status
= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len, find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
decimal_opt, "Bad DECIMAL parameter in data transfer " decimal_opt, "Bad DECIMAL parameter in data transfer "
"statement"); "statement");
if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED) if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal; dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
/* Check the sign mode. */ /* Check the sign mode. */
dtp->u.p.sign_status dtp->u.p.sign_status
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED : = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt, find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement"); "Bad SIGN parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED) if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign; dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
/* Check the blank mode. */ /* Check the blank mode. */
dtp->u.p.blank_status dtp->u.p.blank_status
= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED : = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len, find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len,
blank_opt, blank_opt,
"Bad BLANK parameter in data transfer statement"); "Bad BLANK parameter in data transfer statement");
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
/* Check the delim mode. */ /* Check the delim mode. */
dtp->u.p.delim_status dtp->u.p.current_unit->delim_status
= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED : = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len, find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
delim_opt, delim_opt, "Bad DELIM parameter in data transfer statement");
"Bad DELIM parameter in data transfer statement");
if (dtp->u.p.delim_status == DELIM_UNSPECIFIED) if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim; dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
/* Check the pad mode. */ /* Check the pad mode. */
dtp->u.p.pad_status dtp->u.p.current_unit->pad_status
= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED : = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt, find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
"Bad PAD parameter in data transfer statement"); "Bad PAD parameter in data transfer statement");
if (dtp->u.p.pad_status == PAD_UNSPECIFIED) if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad; dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
}
/* Sanity checks on the record number. */ /* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0) if ((cf & IOPARM_DT_HAS_REC) != 0)
......
libgfortran/io/write.c
...@@ -65,9 +65,7 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source, ...@@ -65,9 +65,7 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
} }
/* Get ready to handle delimiters if needed. */ /* Get ready to handle delimiters if needed. */
d = ' '; switch (dtp->u.p.current_unit->delim_status)
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{ {
case DELIM_APOSTROPHE: case DELIM_APOSTROPHE:
d = '\''; d = '\'';
...@@ -129,9 +127,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source, ...@@ -129,9 +127,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
} }
/* Get ready to handle delimiters if needed. */ /* Get ready to handle delimiters if needed. */
d = ' '; switch (dtp->u.p.current_unit->delim_status)
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{ {
case DELIM_APOSTROPHE: case DELIM_APOSTROPHE:
d = '\''; d = '\'';
...@@ -882,9 +878,7 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length) ...@@ -882,9 +878,7 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
int i, extra; int i, extra;
char *p, d; char *p, d;
d = ' '; switch (dtp->u.p.current_unit->delim_status)
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
switch (dtp->u.p.delim_status)
{ {
case DELIM_APOSTROPHE: case DELIM_APOSTROPHE:
d = '\''; d = '\'';
...@@ -1022,10 +1016,8 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d) ...@@ -1022,10 +1016,8 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
static void static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size) write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{ {
char semi_comma = ','; char semi_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
if (dtp->common.flags & IOPARM_DT_HAS_F2003)
semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
if (write_char (dtp, '(')) if (write_char (dtp, '('))
return; return;
...@@ -1072,17 +1064,9 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, ...@@ -1072,17 +1064,9 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
} }
else else
{ {
if (dtp->common.flags & IOPARM_DT_HAS_F2003) if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
{ dtp->u.p.current_unit->delim_status != DELIM_NONE)
if (type != BT_CHARACTER || !dtp->u.p.char_flag || write_separator (dtp);
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) switch (type)
...@@ -1197,10 +1181,8 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, ...@@ -1197,10 +1181,8 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
/* Set the character to be used to separate values /* Set the character to be used to separate values
to a comma or semi-colon. */ to a comma or semi-colon. */
char semi_comma = ','; char semi_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
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, /* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */ nothing is output. If a component, base and base_name are set. */
...@@ -1315,25 +1297,20 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, ...@@ -1315,25 +1297,20 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break; break;
case GFC_DTYPE_CHARACTER: case GFC_DTYPE_CHARACTER:
if (dtp->common.flags & IOPARM_DT_HAS_F2003) tmp_delim = dtp->u.p.current_unit->delim_status;
{ if (dtp->u.p.nml_delim == '"')
tmp_delim = dtp->u.p.delim_status; dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
if (dtp->u.p.nml_delim == '"') if (dtp->u.p.nml_delim == '\'')
dtp->u.p.delim_status = DELIM_QUOTE; dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
if (dtp->u.p.nml_delim == '\'') write_character (dtp, p, 1, obj->string_length);
dtp->u.p.delim_status = DELIM_APOSTROPHE; dtp->u.p.current_unit->delim_status = tmp_delim;
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; break;
case GFC_DTYPE_REAL: case GFC_DTYPE_REAL:
write_real (dtp, p, len); write_real (dtp, p, len);
break; break;
case GFC_DTYPE_COMPLEX: case GFC_DTYPE_COMPLEX:
dtp->u.p.no_leading_blank = 0; dtp->u.p.no_leading_blank = 0;
num++; num++;
write_complex (dtp, p, len, obj_size); write_complex (dtp, p, len, obj_size);
...@@ -1464,9 +1441,7 @@ namelist_write (st_parameter_dt *dtp) ...@@ -1464,9 +1441,7 @@ namelist_write (st_parameter_dt *dtp)
unit_delim tmp_delim = DELIM_UNSPECIFIED; unit_delim tmp_delim = DELIM_UNSPECIFIED;
/* Set the delimiter for namelist output. */ /* Set the delimiter for namelist output. */
if (dtp->common.flags & IOPARM_DT_HAS_F2003) tmp_delim = dtp->u.p.current_unit->delim_status;
{
tmp_delim = dtp->u.p.delim_status;
switch (tmp_delim) switch (tmp_delim)
{ {
case (DELIM_QUOTE): case (DELIM_QUOTE):
...@@ -1483,8 +1458,8 @@ if (dtp->common.flags & IOPARM_DT_HAS_F2003) ...@@ -1483,8 +1458,8 @@ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
} }
/* Temporarily disable namelist delimters. */ /* Temporarily disable namelist delimters. */
dtp->u.p.delim_status = DELIM_NONE; dtp->u.p.current_unit->delim_status = DELIM_NONE;
}
write_character (dtp, "&", 1, 1); write_character (dtp, "&", 1, 1);
/* Write namelist name in upper case - f95 std. */ /* Write namelist name in upper case - f95 std. */
...@@ -1507,8 +1482,7 @@ if (dtp->common.flags & IOPARM_DT_HAS_F2003) ...@@ -1507,8 +1482,7 @@ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
write_character (dtp, " /", 1, 3); write_character (dtp, " /", 1, 3);
namelist_write_newline (dtp); namelist_write_newline (dtp);
/* Restore the original delimiter. */ /* Restore the original delimiter. */
if (dtp->common.flags & IOPARM_DT_HAS_F2003) dtp->u.p.current_unit->delim_status = tmp_delim;
dtp->u.p.delim_status = tmp_delim;
} }
#undef NML_DIGITS #undef NML_DIGITS
libgfortran/io/write_float.def
...@@ -404,10 +404,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, ...@@ -404,10 +404,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
out += nbefore; out += nbefore;
} }
/* Output the decimal point. */ /* Output the decimal point. */
if (dtp->common.flags & IOPARM_DT_HAS_F2003) *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
*(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
else
*(out++) = '.';
/* Output leading zeros after the decimal point. */ /* Output leading zeros after the decimal point. */
if (nzero > 0) if (nzero > 0)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment