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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162260
138bc75d-0d04-0410-961f-
82ee72b054a4
+2010-07-16 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <jvdelisle@gcc.gnu.org>
PR libfortran/44934
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);
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) ' ';
+ }
}
}
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))
{
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)
{
}
+/* 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. */
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
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);
{
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)
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;
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)
/* 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);
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)
{
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. */
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
OSDN Git Service
