From: Jerry DeLisle Date: Fri, 16 Jul 2010 14:16:04 +0000 (+0000) Subject: re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4) X-Git-Tag: upstream/12.2.0~91458 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=74db2a472ab3ef14f7022d8680a7545bcd95a075;p=platform%2Fupstream%2Fgcc.git re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4) 2010-07-16 Jerry DeLisle PR libfortran/37077 * io/read.c (read_default_char4): Add support for reading into a kind-4 character variable from a character(kind=4) internal unit. * io/io.h (read_block_form4): Add prototype. * io/unit.c (get_internal_unit): Add call to fbuf_init. (free_internal_unit): Add call to fbuf_destroy. (get_unit): Fix whitespace. * io/transfer.c (read_sf_internal): Use fbuf_alloc to allocate a string to recieve the wide characters translated to single byte chracters. (read_block_form): Fix whitespace. (read_block_form4): New function to read from a character(kind=4) internal unit into a character(kind=4) variable. (read_block_direct): Fix whitespace. (write_block): Fix whitespace. (formatted_transfer_scalar_read): Likewise. (formatted_transfer_scalar_write): Likewise. * io/write.c (write_character): Add support for list directed write of a kind=1 character string to a character(kind=4) internal unit. From-SVN: r162260 --- diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 3abdc04..3f8fddd 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,22 @@ +2010-07-16 Jerry DeLisle + + PR libfortran/37077 + * io/read.c (read_default_char4): Add support for reading into a + kind-4 character variable from a character(kind=4) internal unit. + * io/io.h (read_block_form4): Add prototype. + * io/unit.c (get_internal_unit): Add call to fbuf_init. + (free_internal_unit): Add call to fbuf_destroy. (get_unit): Fix + whitespace. + * io/transfer.c (read_sf_internal): Use fbuf_alloc to allocate a string + to recieve the wide characters translated to single byte chracters. + (read_block_form): Fix whitespace. (read_block_form4): New function to + read from a character(kind=4) internal unit into a character(kind=4) + variable. (read_block_direct): Fix whitespace. (write_block): Fix + whitespace. (formatted_transfer_scalar_read): Likewise. + (formatted_transfer_scalar_write): Likewise. + * io/write.c (write_character): Add support for list directed write of + a kind=1 character string to a character(kind=4) internal unit. + 2010-07-14 Jerry DeLisle PR libfortran/44934 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index fbc2fa3..9955348 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -644,6 +644,9 @@ internal_proto(type_name); extern void * read_block_form (st_parameter_dt *, int *); internal_proto(read_block_form); +extern void * read_block_form4 (st_parameter_dt *, int *); +internal_proto(read_block_form4); + extern void *write_block (st_parameter_dt *, int); internal_proto(write_block); diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index 92983d5..357ee9f 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -383,26 +383,51 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width) static void read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width) { - char *s; - gfc_char4_t *dest; int m, n; + gfc_char4_t *dest; - s = read_block_form (dtp, &width); - - if (s == NULL) - return; - if (width > len) - s += (width - len); + if (is_char4_unit(dtp)) + { + gfc_char4_t *s4; - m = ((int) width > len) ? len : (int) width; - - dest = (gfc_char4_t *) p; - - for (n = 0; n < m; n++, dest++, s++) - *dest = (unsigned char ) *s; + s4 = (gfc_char4_t *) read_block_form4 (dtp, &width); + + if (s4 == NULL) + return; + if (width > len) + s4 += (width - len); - for (n = 0; n < len - (int) width; n++, dest++) - *dest = (unsigned char) ' '; + m = ((int) width > len) ? len : (int) width; + + dest = (gfc_char4_t *) p; + + for (n = 0; n < m; n++) + *dest++ = *s4++; + + for (n = 0; n < len - (int) width; n++) + *dest++ = (gfc_char4_t) ' '; + } + else + { + char *s; + + s = read_block_form (dtp, &width); + + if (s == NULL) + return; + if (width > len) + s += (width - len); + + m = ((int) width > len) ? len : (int) width; + + dest = (gfc_char4_t *) p; + + for (n = 0; n < m; n++, dest++, s++) + *dest = (unsigned char ) *s; + + for (n = 0; n < len - (int) width; n++, dest++) + *dest = (unsigned char) ' '; + } } diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index e8bf064..bab1c932 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -202,7 +202,17 @@ read_sf_internal (st_parameter_dt *dtp, int * length) } lorig = *length; - base = mem_alloc_r (dtp->u.p.current_unit->s, length); + if (is_char4_unit(dtp)) + { + int i; + gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, + length); + base = fbuf_alloc (dtp->u.p.current_unit, lorig); + for (i = 0; i < *length; i++, p++) + base[i] = *p > 255 ? '?' : (unsigned char) *p; + } + else + base = mem_alloc_r (dtp->u.p.current_unit->s, length); if (unlikely (lorig > *length)) { @@ -430,7 +440,7 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) dtp->u.p.size_used += (GFC_IO_INT) *nbytes; if (norig != *nbytes) - { + { /* Short read, this shouldn't happen. */ if (!dtp->u.p.current_unit->pad_status == PAD_YES) { @@ -445,6 +455,52 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) } +/* Read a block from a character(kind=4) internal unit, to be transferred into + a character(kind=4) variable. Note: Portions of this code borrowed from + read_sf_internal. */ +void * +read_block_form4 (st_parameter_dt *dtp, int * nbytes) +{ + static gfc_char4_t *empty_string[0]; + gfc_char4_t *source; + int lorig; + + if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) + *nbytes = dtp->u.p.current_unit->bytes_left; + + /* Zero size array gives internal unit len of 0. Nothing to read. */ + if (dtp->internal_unit_len == 0 + && dtp->u.p.current_unit->pad_status == PAD_NO) + hit_eof (dtp); + + /* If we have seen an eor previously, return a length of 0. The + caller is responsible for correctly padding the input field. */ + if (dtp->u.p.sf_seen_eor) + { + *nbytes = 0; + /* Just return something that isn't a NULL pointer, otherwise the + caller thinks an error occured. */ + return empty_string; + } + + lorig = *nbytes; + source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes); + + if (unlikely (lorig > *nbytes)) + { + hit_eof (dtp); + return NULL; + } + + dtp->u.p.current_unit->bytes_left -= *nbytes; + + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + dtp->u.p.size_used += (GFC_IO_INT) *nbytes; + + return source; +} + + /* Reads a block directly into application data space. This is for unformatted files. */ @@ -561,7 +617,6 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) have_read_record += have_read_subrecord; if (unlikely (to_read_subrecord != have_read_subrecord)) - { /* Short read, e.g. if we hit EOF. This means the record structure has been corrupted, or the trailing record @@ -640,7 +695,7 @@ write_block (st_parameter_dt *dtp, int length) if (is_internal_unit (dtp)) { - if (dtp->common.unit) /* char4 internal unit. */ + if (dtp->common.unit) /* char4 internel unit. */ dest = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); else dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); @@ -658,10 +713,10 @@ write_block (st_parameter_dt *dtp, int length) { dest = fbuf_alloc (dtp->u.p.current_unit, length); if (dest == NULL) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return NULL; - } + { + generate_error (&dtp->common, LIBERROR_OS, NULL); + return NULL; + } } if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) @@ -1258,7 +1313,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind consume_data_flag = 0; dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; break; - + case FMT_RC: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE; @@ -1539,7 +1594,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin write_i (dtp, f, p, kind); break; case BT_LOGICAL: - write_l (dtp, f, p, kind); + write_l (dtp, f, p, kind); break; case BT_CHARACTER: if (kind == 4) diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 4e7dc5f..a0018db 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -424,8 +424,11 @@ get_internal_unit (st_parameter_dt *dtp) /* Set initial values for unit parameters. */ if (dtp->common.unit) - iunit->s = open_internal4 (dtp->internal_unit - start_record, - dtp->internal_unit_len, -start_record); + { + iunit->s = open_internal4 (dtp->internal_unit - start_record, + dtp->internal_unit_len, -start_record); + fbuf_init (iunit, 256); + } else iunit->s = open_internal (dtp->internal_unit - start_record, dtp->internal_unit_len, -start_record); @@ -475,6 +478,9 @@ free_internal_unit (st_parameter_dt *dtp) if (!is_internal_unit (dtp)) return; + if (unlikely (is_char4_unit (dtp))) + fbuf_destroy (dtp->u.p.current_unit); + if (dtp->u.p.current_unit != NULL) { if (dtp->u.p.current_unit->ls != NULL) @@ -497,7 +503,7 @@ get_unit (st_parameter_dt *dtp, int do_create) { if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0) - return get_internal_unit(dtp); + return get_internal_unit (dtp); /* Has to be an external unit. */ diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 07c9f54..fe61347 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1340,6 +1340,29 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length) if (p == NULL) return; + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t d4 = (gfc_char4_t) d; + gfc_char4_t *p4 = (gfc_char4_t *) p; + + if (d4 == ' ') + memcpy4 (p4, 0, source, length); + else + { + *p4++ = d4; + + for (i = 0; i < length; i++) + { + *p4++ = (gfc_char4_t) source[i]; + if (source[i] == d) + *p4++ = d4; + } + + *p4 = d4; + } + return; + } + if (d == ' ') memcpy (p, source, length); else