From: Jerry DeLisle <jvdelisle@verizon.net>
To: Fortran List <fortran@gcc.gnu.org>
Cc: gcc-patches <gcc-patches@gcc.gnu.org>
Subject: Re: [patch,fortran] F2003 Inquire features
Date: Mon, 07 Apr 2008 20:50:00 -0000 [thread overview]
Message-ID: <1207600680.2924.21.camel@lenova.localdomain> (raw)
In-Reply-To: <1207551605.19244.1.camel@lenova.localdomain>
[-- Attachment #1: Type: text/plain, Size: 2671 bytes --]
On Mon, 2008-04-07 at 00:00 -0700, Jerry DeLisle wrote:
> On Sun, 2008-04-06 at 23:53 -0700, Jerry DeLisle wrote:
> > Hi,
> >
> > Attached is the next installment on this effort. This patch implements
> > the remaining inquire specifiers. It also adds the pad=, and delim=
> > features. The delim= now works for list directed WRITE.
> >
> > I also enabled encoding="default" and round= in the INQUIRE.
> >
> > I am working up some test cases now but thought it useful for people to
> > start reviewing and independent testing.
> >
> > I have one constraint to add which is ID= in an INQUIRE must be
> > accompanied by a pending= .
Attached is the final patch of this installment.
Regression tested and NIST tested. I am still working up test cases to
add.
OK to commit?
Regards,
Jerry
2008-04-07 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* gfortran.dg/write_check2.f90: Update dg-error.
* gfortran.dg/io_constraints_1.f90: Update dg-error.
2008-04-07 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* io.c (io_tag): Add new tags for decimal, encoding, asynchronous,
round, sign, and id. (match_open_element): Match new tags.
(gfc_resolve_open): Resolve new tags. (gfc_match_open): Enable encoding
for DEFAULT only. Update error messages. (match_dt_element): Fix match
tag for asynchronous. Update error messages. (gfc_free_inquire): Free
new expressions. (match_inquire_element): Match new tags.
(gfc_match_inquire): Add constraint for ID and PENDING.
(gfc_resolve_inquire): Resolve new tags.
* trans-io.c (gfc_trans_inquire): Clean up whitespace and fix setting
of
mask for ID parameter.
* ioparm.def: Fix order of parameters for pending, round, and sign.
NOTE: These must line up with the definitions in libgfortran/io/io.h.
or
things don't work.
2008-04-07 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* io/open.c (edit_modes): Set flags.async. (new_unit) Set flags.async
and flags.status. (st_open): Initialize flags.async.
* io/list_read.c (read_charactor): Use delim_status instead of
flags.delim.
* io/read.c (read_x): Use pad_status instead of flags.pad.
* io/inquire.c (inquire_via_unit): Add new checks.
(inquire_via_filename): Likewise.
* io/io.h (st_parameter_inquire): Add new flags.
(st_parameter_dt): Likewise.
* io/unit.c (get_internal_unit): Set flags.async. (init_units): Set
flags.async.
* io/transfer.c: Add delim and pad option arrays. (read_sf): Use
pad_status instead of flags.pad. (read_block): Likewise.
(data_transfer_init): Set flags.async and add checks.
* io/write.c (write_character): Use delim_status.
(list_formatted_write_scalar): Likewise. (nml_write_obj): Likewise.
(namelist_write): Likewise.
[-- Attachment #2: f2003-inquire-revC.diff --]
[-- Type: text/x-patch, Size: 32845 bytes --]
Index: gcc/testsuite/gfortran.dg/write_check2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/write_check2.f90 (revision 133973)
+++ gcc/testsuite/gfortran.dg/write_check2.f90 (working copy)
@@ -4,7 +4,7 @@
character(len=20) :: str
write(13,'(a)',advance='yes') 'Hello:'
write(13,'(a)',advance='no') 'Hello:'
- write(13,'(a)',advance='y') 'Hello:' ! { dg-error "ADVANCE=specifier at \\(1\\) must have value = YES or NO." }
- write(13,'(a)',advance='yet') 'Hello:' ! { dg-error "ADVANCE=specifier at \\(1\\) must have value = YES or NO." }
- write(13,'(a)',advance='yess') 'Hello:' ! { dg-error "ADVANCE=specifier at \\(1\\) must have value = YES or NO." }
+ write(13,'(a)',advance='y') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." }
+ write(13,'(a)',advance='yet') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." }
+ write(13,'(a)',advance='yess') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." }
end
Index: gcc/testsuite/gfortran.dg/io_constraints_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/io_constraints_1.f90 (revision 133973)
+++ gcc/testsuite/gfortran.dg/io_constraints_1.f90 (working copy)
@@ -62,7 +62,7 @@ end module global
!Was correctly picked up before patch.
write(1, fmt='(i6)', eor = 100) a ! { dg-error "EOR tag" }
!Was correctly picked up before patch.
- write(1, fmt='(i6)', size = b) a ! { dg-error "SIZE=specifier not allowed" }
+ write(1, fmt='(i6)', size = b) a ! { dg-error "SIZE= specifier not allowed" }
READ(1, fmt='(i6)', end = 900) a ! { dg-error "not defined" }
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c (revision 133973)
+++ gcc/fortran/io.c (working copy)
@@ -50,6 +50,7 @@ static const io_tag
tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER},
tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
+ tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER},
tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER},
tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER},
@@ -81,14 +82,19 @@ static const io_tag
tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER},
tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER},
+ tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
+ tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
+ tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
+ tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER},
+ tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER},
tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER},
tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER},
tag_err = {"ERR", " err =", " %l", BT_UNKNOWN},
tag_end = {"END", " end =", " %l", BT_UNKNOWN},
tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN},
- tag_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
- tag_id = {"ID", " id =", " %v", BT_INTEGER};
+ tag_id = {"ID", " id =", " %v", BT_INTEGER},
+ tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL};
static gfc_dt *current_dt;
@@ -1277,7 +1283,7 @@ match_open_element (gfc_open *open)
{
match m;
- m = match_etag (&tag_async, &open->asynchronous);
+ m = match_etag (&tag_e_async, &open->asynchronous);
if (m != MATCH_NO)
return m;
m = match_etag (&tag_unit, &open->unit);
@@ -1394,6 +1400,7 @@ gfc_resolve_open (gfc_open *open)
RESOLVE_TAG (&tag_e_pad, open->pad);
RESOLVE_TAG (&tag_e_decimal, open->decimal);
RESOLVE_TAG (&tag_e_encoding, open->encoding);
+ RESOLVE_TAG (&tag_e_async, open->asynchronous);
RESOLVE_TAG (&tag_e_round, open->round);
RESOLVE_TAG (&tag_e_sign, open->sign);
RESOLVE_TAG (&tag_convert, open->convert);
@@ -1652,16 +1659,13 @@ gfc_match_open (void)
/* Checks on the ENCODING specifier. */
if (open->encoding)
{
- /* When implemented, change the following to use gfc_notify_std F2003.
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
"not allowed in Fortran 95") == FAILURE)
- goto cleanup; */
- gfc_error ("F2003 Feature: ENCODING=specifier at %C not implemented");
- goto cleanup;
+ goto cleanup;
if (open->encoding->expr_type == EXPR_CONSTANT)
{
- static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
+ static const char * encoding[] = { "DEFAULT", NULL };
if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
open->encoding->value.character.string,
@@ -1707,7 +1711,7 @@ gfc_match_open (void)
if (open->round)
{
/* When implemented, change the following to use gfc_notify_std F2003. */
- gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented");
+ gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
goto cleanup;
if (open->round->expr_type == EXPR_CONSTANT)
@@ -1772,8 +1776,8 @@ gfc_match_open (void)
"OPEN", warn))
goto cleanup;
- /* F2003, 9.4.5: If the STATUS=specifier has the value NEW or REPLACE,
- the FILE=specifier shall appear. */
+ /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
+ the FILE= specifier shall appear. */
if (open->file == NULL
&& (strncasecmp (open->status->value.character.string, "replace", 7)
== 0
@@ -1785,8 +1789,8 @@ gfc_match_open (void)
open->status->value.character.string);
}
- /* F2003, 9.4.5: If the STATUS=specifier has the value SCRATCH,
- the FILE=specifier shall not appear. */
+ /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
+ the FILE= specifier shall not appear. */
if (strncasecmp (open->status->value.character.string, "scratch", 7)
== 0 && open->file)
{
@@ -2324,7 +2328,7 @@ match_dt_element (io_kind k, gfc_dt *dt)
return MATCH_YES;
}
- m = match_etag (&tag_async, &dt->asynchronous);
+ m = match_etag (&tag_e_async, &dt->asynchronous);
if (m != MATCH_NO)
return m;
m = match_etag (&tag_e_blank, &dt->blank);
@@ -2869,13 +2873,13 @@ if (condition) \
io_constraint (dt->eor, "EOR tag not allowed with output at %L",
&dt->eor_where);
- io_constraint (dt->blank, "BLANK=specifier not allowed with output at %L",
+ io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
&dt->blank->where);
- io_constraint (dt->pad, "PAD=specifier not allowed with output at %L",
+ io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
&dt->pad->where);
- io_constraint (dt->size, "SIZE=specifier not allowed with output at %L",
+ io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
&dt->size->where);
}
else
@@ -2912,7 +2916,7 @@ if (condition) \
io_constraint (!dt->asynchronous
|| strcmp (dt->asynchronous->value.character.string,
"yes"),
- "ID=specifier at %L must be with ASYNCHRONOUS='yes' "
+ "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
"specifier", &dt->id->where);
}
@@ -2932,7 +2936,7 @@ if (condition) \
return MATCH_ERROR;
io_constraint (unformatted,
- "the DECIMAL=specifier at %L must be with an "
+ "the DECIMAL= specifier at %L must be with an "
"explicit format expression", &dt->decimal->where);
}
}
@@ -2953,7 +2957,7 @@ if (condition) \
return MATCH_ERROR;
io_constraint (unformatted,
- "the BLANK=specifier at %L must be with an "
+ "the BLANK= specifier at %L must be with an "
"explicit format expression", &dt->blank->where);
}
}
@@ -2974,7 +2978,7 @@ if (condition) \
return MATCH_ERROR;
io_constraint (unformatted,
- "the PAD=specifier at %L must be with an "
+ "the PAD= specifier at %L must be with an "
"explicit format expression", &dt->pad->where);
}
}
@@ -2985,7 +2989,7 @@ if (condition) \
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
"not allowed in Fortran 95") == FAILURE)
return MATCH_ERROR; */
- gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented");
+ gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
return MATCH_ERROR;
if (dt->round->expr_type == EXPR_CONSTANT)
@@ -3018,11 +3022,11 @@ if (condition) \
return MATCH_ERROR;
io_constraint (unformatted,
- "SIGN=specifier at %L must be with an "
+ "SIGN= specifier at %L must be with an "
"explicit format expression", &dt->sign->where);
io_constraint (k == M_READ,
- "SIGN=specifier at %L not allowed in a "
+ "SIGN= specifier at %L not allowed in a "
"READ statement", &dt->sign->where);
}
}
@@ -3043,17 +3047,17 @@ if (condition) \
return MATCH_ERROR;
io_constraint (k == M_READ,
- "DELIM=specifier at %L not allowed in a "
+ "DELIM= specifier at %L not allowed in a "
"READ statement", &dt->delim->where);
io_constraint (dt->format_label != &format_asterisk
&& dt->namelist == NULL,
- "DELIM=specifier at %L must have FMT=*",
+ "DELIM= specifier at %L must have FMT=*",
&dt->delim->where);
io_constraint (unformatted && dt->namelist == NULL,
- "DELIM=specifier at %L must be with FMT=* or "
- "NML=specifier ", &dt->delim->where);
+ "DELIM= specifier at %L must be with FMT=* or "
+ "NML= specifier ", &dt->delim->where);
}
}
@@ -3073,11 +3077,11 @@ if (condition) \
"and format label at %L", spec_end);
io_constraint (dt->rec,
- "NAMELIST IO is not allowed with a REC=specifier "
+ "NAMELIST IO is not allowed with a REC= specifier "
"at %L.", &dt->rec->where);
io_constraint (dt->advance,
- "NAMELIST IO is not allowed with a ADVANCE=specifier "
+ "NAMELIST IO is not allowed with a ADVANCE= specifier "
"at %L.", &dt->advance->where);
}
@@ -3085,10 +3089,10 @@ if (condition) \
{
io_constraint (dt->end,
"An END tag is not allowed with a "
- "REC=specifier at %L.", &dt->end_where);
+ "REC= specifier at %L.", &dt->end_where);
io_constraint (dt->format_label == &format_asterisk,
- "FMT=* is not allowed with a REC=specifier "
+ "FMT=* is not allowed with a REC= specifier "
"at %L.", spec_end);
}
@@ -3099,10 +3103,10 @@ if (condition) \
io_constraint (dt->format_label == &format_asterisk,
"List directed format(*) is not allowed with a "
- "ADVANCE=specifier at %L.", &expr->where);
+ "ADVANCE= specifier at %L.", &expr->where);
io_constraint (unformatted,
- "the ADVANCE=specifier at %L must appear with an "
+ "the ADVANCE= specifier at %L must appear with an "
"explicit format expression", &expr->where);
if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
@@ -3118,7 +3122,7 @@ if (condition) \
}
io_constraint (not_no && not_yes,
- "ADVANCE=specifier at %L must have value = "
+ "ADVANCE= specifier at %L must have value = "
"YES or NO.", &expr->where);
io_constraint (dt->size && not_no && k == M_READ,
@@ -3418,10 +3422,16 @@ gfc_free_inquire (gfc_inquire *inquire)
gfc_free_expr (inquire->write);
gfc_free_expr (inquire->readwrite);
gfc_free_expr (inquire->delim);
+ gfc_free_expr (inquire->encoding);
gfc_free_expr (inquire->pad);
gfc_free_expr (inquire->iolength);
gfc_free_expr (inquire->convert);
gfc_free_expr (inquire->strm_pos);
+ gfc_free_expr (inquire->asynchronous);
+ gfc_free_expr (inquire->pending);
+ gfc_free_expr (inquire->id);
+ gfc_free_expr (inquire->sign);
+ gfc_free_expr (inquire->round);
gfc_free (inquire);
}
@@ -3459,11 +3469,19 @@ match_inquire_element (gfc_inquire *inqu
RETM m = match_vtag (&tag_read, &inquire->read);
RETM m = match_vtag (&tag_write, &inquire->write);
RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
+ RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
RETM m = match_vtag (&tag_s_delim, &inquire->delim);
+ RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
+ RETM m = match_vtag (&tag_s_blank, &inquire->blank);
+ RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
+ RETM m = match_vtag (&tag_s_round, &inquire->round);
+ RETM m = match_vtag (&tag_s_sign, &inquire->sign);
RETM m = match_vtag (&tag_s_pad, &inquire->pad);
RETM m = match_vtag (&tag_iolength, &inquire->iolength);
RETM m = match_vtag (&tag_convert, &inquire->convert);
RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
+ RETM m = match_vtag (&tag_pending, &inquire->pending);
+ RETM m = match_vtag (&tag_id, &inquire->id);
RETM return MATCH_NO;
}
@@ -3571,6 +3589,13 @@ gfc_match_inquire (void)
gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
goto cleanup;
}
+
+ if (inquire->id != NULL && inquire->pending == NULL)
+ {
+ gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
+ "the ID= specifier", &loc);
+ goto cleanup;
+ }
new_st.op = EXEC_INQUIRE;
new_st.ext.inquire = inquire;
@@ -3615,9 +3640,16 @@ gfc_resolve_inquire (gfc_inquire *inquir
RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
RESOLVE_TAG (&tag_s_delim, inquire->delim);
RESOLVE_TAG (&tag_s_pad, inquire->pad);
+ RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
+ RESOLVE_TAG (&tag_s_round, inquire->round);
RESOLVE_TAG (&tag_iolength, inquire->iolength);
RESOLVE_TAG (&tag_convert, inquire->convert);
RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
+ RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
+ RESOLVE_TAG (&tag_s_sign, inquire->sign);
+ RESOLVE_TAG (&tag_s_round, inquire->round);
+ RESOLVE_TAG (&tag_pending, inquire->pending);
+ RESOLVE_TAG (&tag_id, inquire->id);
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 133973)
+++ gcc/fortran/trans-io.c (working copy)
@@ -1238,6 +1238,10 @@ gfc_trans_inquire (gfc_code * code)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
p->blank);
+ if (p->delim)
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+ p->delim);
+
if (p->position)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
p->position);
@@ -1258,14 +1262,10 @@ gfc_trans_inquire (gfc_code * code)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
p->readwrite);
- if (p->delim)
- mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
- p->delim);
-
if (p->pad)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
p->pad);
-
+
if (p->convert)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
p->convert);
@@ -1304,7 +1304,8 @@ gfc_trans_inquire (gfc_code * code)
p->size);
if (p->id)
- mask2 |= set_parameter_value (&block, var, IOPARM_inquire_id, p->id);
+ mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
+ p->id);
set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
Index: gcc/fortran/ioparm.def
===================================================================
--- gcc/fortran/ioparm.def (revision 133973)
+++ gcc/fortran/ioparm.def (working copy)
@@ -63,9 +63,9 @@ IOPARM (inquire, flags2, 1 << 31, int4)
IOPARM (inquire, asynchronous, 1 << 0, char1)
IOPARM (inquire, decimal, 1 << 1, char2)
IOPARM (inquire, encoding, 1 << 2, char1)
-IOPARM (inquire, round, 1 << 3, char2)
-IOPARM (inquire, sign, 1 << 4, char1)
-IOPARM (inquire, pending, 1 << 5, pint4)
+IOPARM (inquire, pending, 1 << 3, pint4)
+IOPARM (inquire, round, 1 << 4, char1)
+IOPARM (inquire, sign, 1 << 5, char2)
IOPARM (inquire, size, 1 << 6, pint4)
IOPARM (inquire, id, 1 << 7, pint4)
IOPARM (wait, common, 0, common)
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (revision 133973)
+++ libgfortran/io/open.c (working copy)
@@ -254,6 +254,8 @@ edit_modes (st_parameter_open *opp, gfc_
u->flags.decimal = flags->decimal;
if (flags->encoding != ENCODING_UNSPECIFIED)
u->flags.encoding = flags->encoding;
+ if (flags->async != ASYNC_UNSPECIFIED)
+ u->flags.async = flags->async;
if (flags->round != ROUND_UNSPECIFIED)
u->flags.round = flags->round;
if (flags->sign != SIGN_UNSPECIFIED)
@@ -317,6 +319,13 @@ new_unit (st_parameter_open *opp, gfc_un
flags->form = (flags->access == ACCESS_SEQUENTIAL)
? FORM_FORMATTED : FORM_UNFORMATTED;
+ if (flags->async == ASYNC_UNSPECIFIED)
+ flags->async = ASYNC_NO;
+
+ if (flags->status == STATUS_UNSPECIFIED)
+ flags->status = STATUS_UNKNOWN;
+
+ /* Checks. */
if (flags->delim == DELIM_UNSPECIFIED)
flags->delim = DELIM_NONE;
@@ -424,12 +433,6 @@ new_unit (st_parameter_open *opp, gfc_un
if (flags->position == POSITION_UNSPECIFIED)
flags->position = POSITION_ASIS;
-
- if (flags->status == STATUS_UNSPECIFIED)
- flags->status = STATUS_UNKNOWN;
-
- /* Checks. */
-
if (flags->access == ACCESS_DIRECT
&& (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{
@@ -739,6 +742,10 @@ st_open (st_parameter_open *opp)
find_option (&opp->common, opp->encoding, opp->encoding_len,
encoding_opt, "Bad ENCODING parameter in OPEN statement");
+ flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
+ find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
+ async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
+
flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
find_option (&opp->common, opp->round, opp->round_len,
round_opt, "Bad ROUND parameter in OPEN statement");
Index: libgfortran/io/list_read.c
===================================================================
--- libgfortran/io/list_read.c (revision 133973)
+++ libgfortran/io/list_read.c (working copy)
@@ -943,8 +943,8 @@ read_character (st_parameter_dt *dtp, in
default:
if (dtp->u.p.namelist_mode)
{
- if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
- || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE
+ if (dtp->u.p.delim_status == DELIM_APOSTROPHE
+ || dtp->u.p.delim_status == DELIM_QUOTE
|| c == '&' || c == '$' || c == '/')
{
unget_char (dtp, c);
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 133973)
+++ libgfortran/io/read.c (working copy)
@@ -854,7 +854,7 @@ read_x (st_parameter_dt *dtp, int n)
{
if (!is_stream_io (dtp))
{
- if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+ 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;
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (revision 133973)
+++ libgfortran/io/inquire.c (working copy)
@@ -43,6 +43,7 @@ inquire_via_unit (st_parameter_inquire *
{
const char *p;
GFC_INTEGER_4 cf = iqp->common.flags;
+ GFC_INTEGER_4 cf2 = iqp->flags2;
if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
{
@@ -213,7 +214,7 @@ inquire_via_unit (st_parameter_inquire *
if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
{
- if (u == NULL)
+ if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
else
switch (u->flags.blank)
@@ -231,6 +232,151 @@ inquire_via_unit (st_parameter_inquire *
cf_strcpy (iqp->blank, iqp->blank_len, p);
}
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+ {
+ if (u == NULL || u->flags.form != FORM_FORMATTED)
+ p = undefined;
+ else
+ switch (u->flags.pad)
+ {
+ case PAD_YES:
+ p = "YES";
+ break;
+ case PAD_NO:
+ p = "NO";
+ break;
+ default:
+ internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
+ }
+
+ cf_strcpy (iqp->pad, iqp->pad_len, p);
+ }
+
+ if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+ *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)
+ p = undefined;
+ else
+ switch (u->flags.encoding)
+ {
+ case ENCODING_DEFAULT:
+ p = "UNKNOWN";
+ break;
+ /* TODO: Enable UTF-8 case here when implemented.
+ 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_SIGN) != 0)
+ {
+ if (u == NULL)
+ p = undefined;
+ else
+ switch (u->flags.sign)
+ {
+ case SIGN_PROCDEFINED:
+ p = "PROCESSOR_DEFINED";
+ break;
+ case SIGN_SUPPRESS:
+ p = "SUPPRESS";
+ break;
+ case SIGN_PLUS:
+ p = "PLUS";
+ break;
+ default:
+ internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
+ }
+
+ cf_strcpy (iqp->sign, iqp->sign_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;
+ case ROUND_UNSPECIFIED:
+ p = "UNSPECIFIED";
+ 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 (u == NULL || u->flags.access == ACCESS_DIRECT)
@@ -380,6 +526,7 @@ inquire_via_filename (st_parameter_inqui
{
const char *p;
GFC_INTEGER_4 cf = iqp->common.flags;
+ GFC_INTEGER_4 cf2 = iqp->flags2;
if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
*iqp->exist = file_exists (iqp->file, iqp->file_len);
@@ -435,6 +582,18 @@ inquire_via_filename (st_parameter_inqui
if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
cf_strcpy (iqp->blank, iqp->blank_len, undefined);
+ if ((cf & 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 ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
+ cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+
+ if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
+ cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
+
if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
cf_strcpy (iqp->position, iqp->position_len, undefined);
@@ -459,11 +618,14 @@ inquire_via_filename (st_parameter_inqui
cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
}
- if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+ if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
cf_strcpy (iqp->delim, iqp->delim_len, undefined);
- if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+ 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);
}
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 133973)
+++ libgfortran/io/io.h (working copy)
@@ -235,7 +235,7 @@ typedef enum
unit_mode;
typedef enum
-{ ASYNC_YES, ASYNC_NO, AYSYNC_UNSPECIFIED }
+{ ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
unit_async;
#define CHARACTER1(name) \
@@ -342,13 +342,13 @@ typedef struct
CHARACTER1 (convert);
GFC_INTEGER_4 flags2;
CHARACTER1 (asynchronous);
- CHARACTER1 (decimal);
+ CHARACTER2 (decimal);
CHARACTER1 (encoding);
- CHARACTER1 (pending);
+ CHARACTER2 (pending);
CHARACTER1 (round);
- CHARACTER1 (sign);
+ CHARACTER2 (sign);
GFC_INTEGER_4 *size;
- GFC_IO_INT id;
+ GFC_INTEGER_4 *id;
}
st_parameter_inquire;
@@ -409,6 +409,7 @@ typedef struct st_parameter_dt
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. */
@@ -423,6 +424,7 @@ typedef struct st_parameter_dt
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;
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c (revision 133973)
+++ libgfortran/io/unit.c (working copy)
@@ -443,6 +443,7 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->flags.sign = SIGN_SUPPRESS;
iunit->flags.decimal = DECIMAL_POINT;
iunit->flags.encoding = ENCODING_DEFAULT;
+ iunit->flags.async = ASYNC_NO;
/* Initialize the data transfer parameters. */
@@ -531,7 +532,8 @@ init_units (void)
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
-
+ u->flags.async = ASYNC_NO;
+
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
@@ -557,6 +559,7 @@ init_units (void)
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
+ u->flags.async = ASYNC_NO;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
@@ -583,6 +586,7 @@ init_units (void)
u->flags.sign = SIGN_SUPPRESS;
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
+ u->flags.async = ASYNC_NO;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 133973)
+++ libgfortran/io/transfer.c (working copy)
@@ -114,6 +114,19 @@ static const st_option blank_opt[] = {
{NULL, 0}
};
+static const st_option delim_opt[] = {
+ {"apostrophe", DELIM_APOSTROPHE},
+ {"quote", DELIM_QUOTE},
+ {"none", DELIM_NONE},
+ {NULL, 0}
+};
+
+static const st_option pad_opt[] = {
+ {"yes", PAD_YES},
+ {"no", PAD_NO},
+ {NULL, 0}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -242,7 +255,7 @@ 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.current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.pad_status == PAD_NO)
{
if (no_error)
break;
@@ -320,7 +333,7 @@ read_block (st_parameter_dt *dtp, int *l
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
- if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.pad_status == PAD_NO)
{
/* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL);
@@ -358,7 +371,7 @@ read_block (st_parameter_dt *dtp, int *l
if (nread != *length)
{ /* Short read, this shouldn't happen. */
- if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+ if (dtp->u.p.pad_status == PAD_YES)
*length = nread;
else
{
@@ -1802,6 +1815,7 @@ data_transfer_init (st_parameter_dt *dtp
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;
@@ -2020,8 +2034,25 @@ data_transfer_init (st_parameter_dt *dtp
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;
+ /* 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)
{
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c (revision 133973)
+++ libgfortran/io/write.c (working copy)
@@ -640,7 +640,7 @@ write_character (st_parameter_dt *dtp, c
int i, extra;
char *p, d;
- switch (dtp->u.p.current_unit->flags.delim)
+ switch (dtp->u.p.delim_status)
{
case DELIM_APOSTROPHE:
d = '\'';
@@ -779,7 +779,7 @@ list_formatted_write_scalar (st_paramete
else
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
- dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+ dtp->u.p.delim_status != DELIM_NONE)
write_separator (dtp);
}
@@ -994,13 +994,13 @@ nml_write_obj (st_parameter_dt *dtp, nam
break;
case GFC_DTYPE_CHARACTER:
- tmp_delim = dtp->u.p.current_unit->flags.delim;
+ tmp_delim = dtp->u.p.delim_status;
if (dtp->u.p.nml_delim == '"')
- dtp->u.p.current_unit->flags.delim = DELIM_QUOTE;
+ dtp->u.p.delim_status = DELIM_QUOTE;
if (dtp->u.p.nml_delim == '\'')
- dtp->u.p.current_unit->flags.delim = DELIM_APOSTROPHE;
+ dtp->u.p.delim_status = DELIM_APOSTROPHE;
write_character (dtp, p, obj->string_length);
- dtp->u.p.current_unit->flags.delim = tmp_delim;
+ dtp->u.p.delim_status = tmp_delim;
break;
case GFC_DTYPE_REAL:
@@ -1141,7 +1141,7 @@ namelist_write (st_parameter_dt *dtp)
/* Set the delimiter for namelist output. */
- tmp_delim = dtp->u.p.current_unit->flags.delim;
+ tmp_delim = dtp->u.p.delim_status;
switch (tmp_delim)
{
case (DELIM_QUOTE):
@@ -1158,7 +1158,7 @@ namelist_write (st_parameter_dt *dtp)
}
/* Temporarily disable namelist delimters. */
- dtp->u.p.current_unit->flags.delim = DELIM_NONE;
+ dtp->u.p.delim_status = DELIM_NONE;
write_character (dtp, "&", 1);
@@ -1186,7 +1186,7 @@ namelist_write (st_parameter_dt *dtp)
#endif
/* Restore the original delimiter. */
- dtp->u.p.current_unit->flags.delim = tmp_delim;
+ dtp->u.p.delim_status = tmp_delim;
}
#undef NML_DIGITS
next parent reply other threads:[~2008-04-07 20:39 UTC|newest]
Thread overview: 3+ messages / expand[flat|nested] mbox.gz Atom feed top
[not found] <1207551203.3028.25.camel@lenova.localdomain>
[not found] ` <1207551605.19244.1.camel@lenova.localdomain>
2008-04-07 20:50 ` Jerry DeLisle [this message]
2008-04-07 21:52 Tobias Burnus
2008-04-07 22:38 ` Jerry DeLisle
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1207600680.2924.21.camel@lenova.localdomain \
--to=jvdelisle@verizon.net \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).