From: Jerry DeLisle Date: Mon, 7 Apr 2008 22:07:44 +0000 (+0000) Subject: PR fortran/25829 28655 X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d06b3496f60fba03f0a742f9adfc0a6174f3f60d;p=gcc.git PR fortran/25829 28655 2008-04-07 Jerry DeLisle PR fortran/25829 28655 * 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. From-SVN: r133989 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 12afa21286b..7833747bec7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2008-04-07 Jerry DeLisle + + PR fortran/25829 28655 + * 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-06 Paul Thomas PR fortran/35780 diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 5ea051c87f9..11907a72a89 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -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,14 @@ 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 }; + /* TODO: Implement UTF-8 here. */ + static const char * encoding[] = { "DEFAULT", NULL }; if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, open->encoding->value.character.string, @@ -1707,7 +1712,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 +1777,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 +1790,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 +2329,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 +2874,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 +2917,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 +2937,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 +2958,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 +2979,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 +2990,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 +3023,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 +3048,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 +3078,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 +3090,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 +3104,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 +3123,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 +3423,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 +3470,19 @@ match_inquire_element (gfc_inquire *inquire) 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 +3590,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 +3641,16 @@ gfc_resolve_inquire (gfc_inquire *inquire) 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; diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def index b16fcb53c31..deb1b98389c 100644 --- a/gcc/fortran/ioparm.def +++ b/gcc/fortran/ioparm.def @@ -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) diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 6bc41e1ce67..6316a426918 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -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);