From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 9822 invoked by alias); 7 Apr 2008 20:39:02 -0000 Received: (qmail 9790 invoked by uid 22791); 7 Apr 2008 20:38:55 -0000 X-Spam-Check-By: sourceware.org Received: from vms048pub.verizon.net (HELO vms048pub.verizon.net) (206.46.252.48) by sourceware.org (qpsmtpd/0.31) with ESMTP; Mon, 07 Apr 2008 20:38:36 +0000 Received: from [192.168.1.5] ([71.120.231.15]) by vms048.mailsrvcs.net (Sun Java System Messaging Server 6.2-6.01 (built Apr 3 2006)) with ESMTPA id <0JYZ00LIR2NC0MT0@vms048.mailsrvcs.net>; Mon, 07 Apr 2008 15:38:04 -0500 (CDT) Date: Mon, 07 Apr 2008 20:50:00 -0000 From: Jerry DeLisle Subject: Re: [patch,fortran] F2003 Inquire features In-reply-to: <1207551605.19244.1.camel@lenova.localdomain> To: Fortran List Cc: gcc-patches Message-id: <1207600680.2924.21.camel@lenova.localdomain> MIME-version: 1.0 X-Mailer: Evolution 2.12.3 (2.12.3-3.fc8) Content-type: multipart/mixed; boundary="=-p3JM0iBHi/WhP8e43Qz4" References: <1207551203.3028.25.camel@lenova.localdomain> <1207551605.19244.1.camel@lenova.localdomain> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2008-04/txt/msg00568.txt.bz2 --=-p3JM0iBHi/WhP8e43Qz4 Content-Type: text/plain Content-Transfer-Encoding: 7bit Content-length: 2671 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 * gfortran.dg/write_check2.f90: Update dg-error. * gfortran.dg/io_constraints_1.f90: Update dg-error. 2008-04-07 Jerry DeLisle * 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 * 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. --=-p3JM0iBHi/WhP8e43Qz4 Content-Disposition: attachment; filename=f2003-inquire-revC.diff Content-Type: text/x-patch; name=f2003-inquire-revC.diff; charset=UTF-8 Content-Transfer-Encoding: 7bit Content-length: 32845 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 --=-p3JM0iBHi/WhP8e43Qz4--