From 931149a6b763268df6377a2951927b2db4e4e350 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Mon, 7 Apr 2008 22:05:52 +0000 Subject: [PATCH] PR fortran/25829 28655 2008-04-07 Jerry DeLisle PR fortran/25829 28655 * 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. From-SVN: r133988 --- libgfortran/ChangeLog | 21 +++++ libgfortran/io/inquire.c | 165 ++++++++++++++++++++++++++++++++++++- libgfortran/io/io.h | 12 +-- libgfortran/io/list_read.c | 4 +- libgfortran/io/open.c | 19 +++-- libgfortran/io/read.c | 2 +- libgfortran/io/transfer.c | 39 ++++++++- libgfortran/io/unit.c | 6 +- libgfortran/io/write.c | 18 ++-- 9 files changed, 255 insertions(+), 31 deletions(-) diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 7c1a3b1e2ca..631d1ac43f1 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,24 @@ +2008-04-07 Jerry DeLisle + + PR fortran/25829 28655 + * 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. + 2008-04-05 Jerry DeLisle PR fortran/25829 28655 diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index ec462858f67..5e0cf3e646c 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -43,6 +43,7 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) { 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 *iqp, gfc_unit * u) 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,148 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) 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; + 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 +523,7 @@ inquire_via_filename (st_parameter_inquire *iqp) { 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 +579,18 @@ inquire_via_filename (st_parameter_inquire *iqp) 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 +615,14 @@ inquire_via_filename (st_parameter_inquire *iqp) 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); } diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index ddbd632a64b..30d4051f126 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -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; diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index ae2eb354d3f..89c55c7c51b 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -943,8 +943,8 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) 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); diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index 5259684e8bf..4e904d37df9 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -254,6 +254,8 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) 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_unit *u, unit_flags * flags) 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_unit *u, unit_flags * flags) 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"); diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index bba37723441..ce86ec00b8f 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -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; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 56e93f2a957..8741758e61d 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -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 *length, int no_error) /* 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 *length) 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 *length) 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, int read_flag) 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, int read_flag) 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) { diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index f1928e6ed8a..9f9e3513dab 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -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; diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index be3c0d79809..ea8ad94b8ca 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -640,7 +640,7 @@ write_character (st_parameter_dt *dtp, const char *source, int length) 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_parameter_dt *dtp, bt type, void *p, int kind, 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, namelist_info * obj, index_type offset, 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 -- 2.30.2