* Re: [patch,fortran] F2003 Inquire features
[not found] ` <1207551605.19244.1.camel@lenova.localdomain>
@ 2008-04-07 20:50 ` Jerry DeLisle
0 siblings, 0 replies; 3+ messages in thread
From: Jerry DeLisle @ 2008-04-07 20:50 UTC (permalink / raw)
To: Fortran List; +Cc: gcc-patches
[-- 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
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [patch,fortran] F2003 Inquire features
2008-04-07 21:52 Tobias Burnus
@ 2008-04-07 22:38 ` Jerry DeLisle
0 siblings, 0 replies; 3+ messages in thread
From: Jerry DeLisle @ 2008-04-07 22:38 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
On Mon, 2008-04-07 at 23:14 +0200, Tobias Burnus wrote:
> > Attached is the final patch of this installment.
>
> Thanks for the patch!
>
> > Regression tested and NIST tested. I am still working up test cases to
> > add.
> >
> > OK to commit?
>
> OK after fixing the issues mentioned below.
>
> Index: gcc/fortran/io.c:
> |
> | if (open->encoding->expr_type == EXPR_CONSTANT)
> | {
> | - static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
> | + static const char * encoding[] = { "DEFAULT", NULL };
>
> Add a TODO: UTF-8 there. (In the library there is already such a TODO.)
>
>
Done
> Index: libgfortran/io/inquire.c:
> + case ROUND_UNSPECIFIED:
> + p = "UNSPECIFIED";
> + break;
>
> This is wrong.
>
Well not really wrong, but it is dead code. This is just translating the
incoming specifier to the corresponding string. That specifier never
happens since it is set to ROUND_PROCDEFINED elsewhere. So inquire
actually returns "PROCESSOR_DEFINED" right now.
I deleted the dead code.
Patch committed. I am working some test cases now to be sutable for the
testsuite.
Thanks for reviews and comments.
Jerry
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [patch,fortran] F2003 Inquire features
@ 2008-04-07 21:52 Tobias Burnus
2008-04-07 22:38 ` Jerry DeLisle
0 siblings, 1 reply; 3+ messages in thread
From: Tobias Burnus @ 2008-04-07 21:52 UTC (permalink / raw)
To: Jerry DeLisle, fortran, gcc-patches
> Attached is the final patch of this installment.
Thanks for the patch!
> Regression tested and NIST tested. I am still working up test cases to
> add.
>
> OK to commit?
OK after fixing the issues mentioned below.
Index: gcc/fortran/io.c:
|
| if (open->encoding->expr_type == EXPR_CONSTANT)
| {
| - static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
| + static const char * encoding[] = { "DEFAULT", NULL };
Add a TODO: UTF-8 there. (In the library there is already such a TODO.)
Index: libgfortran/io/inquire.c:
+ case ROUND_UNSPECIFIED:
+ p = "UNSPECIFIED";
+ break;
This is wrong.
The standard mandates ("9.9.1.26 ROUND= specifier in the INQUIRE statement"):
"The scalar-default-char-variable in the ROUND= specifier is assigned
the value UP, DOWN, ZERO, NEAREST, COMPATIBLE, or PROCESSOR_DEFINED,
corresponding to the I/O rounding mode in effect for a connection for
formatted input/output. If there is no connection or if the connection
is not for formatted input/output, the scalar-default-char-variable is
assigned the value UNDEFINED. The processor shall return the value
PROCESSOR_DEFINED only if the I/O rounding mode currently in effect
behaves differently than the UP, DOWN, ZERO, NEAREST, and COMPATIBLE
modes."
Therefore, if the rounding mode has not been specified, the default
rounding mode should be returned. As we currently do not know which one
we have, we should return "PROCESSOR_DEFINED". If you replace the
string, please add also TODO there.
As soon as we figured out which rounding mode gfortran currently has
or which default rounding mode we want to have, we should return this
one instead. (Unless, it turns out that it neither of the up/down/zero/
nearest/compatible, which I do not think.) On my system I have
"COMPATIBLE"; the rounding seems to depend on the system libc's printf
and POSIX says that the rounding is system dependent, which means that
"PROCESSOR_DEFINED" is the right choice - at least for the moment.
Tobias
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2008-04-07 22:18 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
[not found] <1207551203.3028.25.camel@lenova.localdomain>
[not found] ` <1207551605.19244.1.camel@lenova.localdomain>
2008-04-07 20:50 ` [patch,fortran] F2003 Inquire features Jerry DeLisle
2008-04-07 21:52 Tobias Burnus
2008-04-07 22:38 ` Jerry DeLisle
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).