mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-23 04:49:12 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4)

Browse Source 
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.

From-SVN: r162260
This commit is contained in:
Jerry DeLisle 2010-07-16 14:16:04 +00:00
parent 4b1b0ac1cf
commit 74db2a472a
6 changed files with 160 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
libgfortran/ChangeLog
View File

@ -1,3 +1,22 @@
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

3
libgfortran/io/io.h
View File

@ -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);

57
libgfortran/io/read.c
View File

@ -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);
for (n = 0; n < len - (int) width; n++, dest++)
*dest = (unsigned char) ' ';
if (s4 == NULL)
return;
if (width > len)
s4 += (width - len);
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) ' ';
}
}

75
libgfortran/io/transfer.c
View File

@ -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)

12
libgfortran/io/unit.c
View File

@ -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. */

23
libgfortran/io/write.c
View File

@ -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