[Patch, fortran] PR24174 real(10) and complex(10) array IO broken.
Janne Blomqvist
jblomqvi@cc.hut.fi
Mon Oct 17 22:36:00 GMT 2005
PING!
On Tue, Oct 11, 2005 at 08:57:38AM +0300, Janne Blomqvist wrote:
> :ADDPATCH fortran:
>
> Hello,
>
> attached is an updated patch for PR24174. It also fixes complex(10)
> formatted output, althought input is still broken (see 24305).
>
> I had to add a kind argument to the transfer_array function, as the
> array descriptor contains the size and not the kind, and we cannot
> uniquely determine the kind from the size (e.g. IA-64 where AFAIK
> real(10) is padded to 16 bytes and real(16) is also available).
>
> --
> Janne Blomqvist
> gfortran ChangeLog
>
> 2005-10-11 Janne Blomqvist <jblomqvi@cc.hut.fi>
>
> PR fortran/24174
> * fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
> argument to transfer_array.
> (transfer_array_desc): Add kind argument.
>
> libgfortran Changelog:
>
> 2005-10-11 Janne Blomqvist <jblomqvi@cc.hut.fi>
>
> PR fortran/24174
> * io/io.h: Add argument to prototypes.
> * io/list_read.c (list_formatted_read): Add size argument, cleanup.
> * io/transfer.c: Add argument to transfer function pointer.
> (unformatted_read): Add size argument.
> (unformatted_write): Likewise.
> (formatted_transfer_scalar): Fix for padding with complex(10).
> (formatted_transfer): Add size argument, cleanup.
> (transfer_integer): Add size argument to transfer call.
> (transfer_real): Likewise.
> (transfer_logical): Likewise.
> (transfer_character): Likewise.
> (transfer_complex): Likewise.
> (transfer_array): New kind argument, use it.
> (data_transfer_init): Add size argument to formatted_transfer
> call.
> (iolength_transfer): Add size argument, cleanup.
> * io/write.c (write_complex): Fix for padding with complex(10).
> (list_formatted_write): Add size argument, cleanup.
>
> Index: gcc/fortran/trans-io.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
> retrieving revision 1.43
> diff -p -u -r1.43 trans-io.c
> --- gcc/fortran/trans-io.c 26 Sep 2005 20:24:43 -0000 1.43
> +++ gcc/fortran/trans-io.c 11 Oct 2005 05:33:00 -0000
> @@ -271,7 +271,8 @@ gfc_build_io_library_fndecls (void)
> iocall_x_array =
> gfc_build_library_function_decl (get_identifier
> (PREFIX("transfer_array")),
> - void_type_node, 2, pvoid_type_node,
> + void_type_node, 3, pvoid_type_node,
> + gfc_int4_type_node,
> gfc_charlen_type_node);
>
> /* Library entry points */
> @@ -1597,14 +1598,17 @@ transfer_expr (gfc_se * se, gfc_typespec
> static void
> transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
> {
> - tree args, tmp, charlen_arg;
> + tree args, tmp, charlen_arg, kind_arg;
>
> if (ts->type == BT_CHARACTER)
> charlen_arg = se->string_length;
> else
> charlen_arg = build_int_cstu (NULL_TREE, 0);
>
> + kind_arg = build_int_cst (NULL_TREE, ts->kind);
> +
> args = gfc_chainon_list (NULL_TREE, addr_expr);
> + args = gfc_chainon_list (args, kind_arg);
> args = gfc_chainon_list (args, charlen_arg);
> tmp = gfc_build_function_call (iocall_x_array, args);
> gfc_add_expr_to_block (&se->pre, tmp);
> Index: libgfortran/io/io.h
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v
> retrieving revision 1.33
> diff -p -u -r1.33 io.h
> --- libgfortran/io/io.h 7 Oct 2005 20:02:28 -0000 1.33
> +++ libgfortran/io/io.h 11 Oct 2005 05:33:01 -0000
> @@ -617,7 +617,7 @@ internal_proto(read_decimal);
>
> /* list_read.c */
>
> -extern void list_formatted_read (bt, void *, int, size_t);
> +extern void list_formatted_read (bt, void *, int, size_t, size_t);
> internal_proto(list_formatted_read);
>
> extern void finish_list_read (void);
> @@ -670,7 +670,7 @@ internal_proto(write_x);
> extern void write_z (fnode *, const char *, int);
> internal_proto(write_z);
>
> -extern void list_formatted_write (bt, void *, int, size_t);
> +extern void list_formatted_write (bt, void *, int, size_t, size_t);
> internal_proto(list_formatted_write);
>
> /* error.c */
> Index: libgfortran/io/list_read.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/list_read.c,v
> retrieving revision 1.28
> diff -p -u -r1.28 list_read.c
> --- libgfortran/io/list_read.c 26 Sep 2005 20:24:44 -0000 1.28
> +++ libgfortran/io/list_read.c 11 Oct 2005 05:33:02 -0000
> @@ -1408,24 +1408,18 @@ list_formatted_read_scalar (bt type, voi
>
>
> void
> -list_formatted_read (bt type, void *p, int len, size_t nelems)
> +list_formatted_read (bt type, void *p, int kind, size_t size, size_t nelems)
> {
> size_t elem;
> - int size;
> char *tmp;
>
> tmp = (char *) p;
>
> - if (type == BT_COMPLEX)
> - size = 2 * len;
> - else
> - size = len;
> -
> /* Big loop over all the elements. */
> for (elem = 0; elem < nelems; elem++)
> {
> g.item_count++;
> - list_formatted_read_scalar (type, tmp + size*elem, len);
> + list_formatted_read_scalar (type, tmp + size*elem, kind);
> }
> }
>
> Index: libgfortran/io/transfer.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
> retrieving revision 1.63
> diff -p -u -r1.63 transfer.c
> --- libgfortran/io/transfer.c 7 Oct 2005 20:02:28 -0000 1.63
> +++ libgfortran/io/transfer.c 11 Oct 2005 05:33:03 -0000
> @@ -78,7 +78,7 @@ export_proto(transfer_character);
> extern void transfer_complex (void *, int);
> export_proto(transfer_complex);
>
> -extern void transfer_array (gfc_array_char *, gfc_charlen_type);
> +extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
> export_proto(transfer_array);
>
> gfc_unit *current_unit = NULL;
> @@ -104,7 +104,7 @@ static const st_option advance_opt[] = {
> };
>
>
> -static void (*transfer) (bt, void *, int, size_t);
> +static void (*transfer) (bt, void *, int, size_t, size_t);
>
>
> typedef enum
> @@ -394,36 +394,26 @@ write_block_direct (void * buf, size_t *
> /* Master function for unformatted reads. */
>
> static void
> -unformatted_read (bt type, void *dest, int length, size_t nelems)
> +unformatted_read (bt type __attribute__((unused)), void *dest,
> + int kind __attribute__((unused)),
> + size_t size, size_t nelems)
> {
> - size_t len;
> + size *= nelems;
>
> - len = length * nelems;
> -
> - /* Transfer functions get passed the kind of the entity, so we have
> - to fix this for COMPLEX data which are twice the size of their
> - kind. */
> - if (type == BT_COMPLEX)
> - len *= 2;
> -
> - read_block_direct (dest, &len);
> + read_block_direct (dest, &size);
> }
>
>
> /* Master function for unformatted writes. */
>
> static void
> -unformatted_write (bt type, void *source, int length, size_t nelems)
> +unformatted_write (bt type __attribute__((unused)), void *source,
> + int kind __attribute__((unused)),
> + size_t size, size_t nelems)
> {
> - size_t len;
> -
> - len = length * nelems;
> + size *= nelems;
>
> - /* Correction for kind vs. length as in unformatted_read. */
> - if (type == BT_COMPLEX)
> - len *= 2;
> -
> - write_block_direct (source, &len);
> + write_block_direct (source, &size);
> }
>
>
> @@ -518,7 +508,7 @@ require_type (bt expected, bt actual, fn
> of the next element, then comes back here to process it. */
>
> static void
> -formatted_transfer_scalar (bt type, void *p, int len)
> +formatted_transfer_scalar (bt type, void *p, int len, size_t size)
> {
> int pos, bytes_used;
> fnode *f;
> @@ -530,7 +520,10 @@ formatted_transfer_scalar (bt type, void
>
> n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
> if (type == BT_COMPLEX)
> - type = BT_REAL;
> + {
> + type = BT_REAL;
> + size /= 2;
> + }
>
> /* If there's an EOR condition, we simulate finalizing the transfer
> by doing nothing. */
> @@ -893,7 +886,7 @@ formatted_transfer_scalar (bt type, void
> if ((consume_data_flag > 0) && (n > 0))
> {
> n--;
> - p = ((char *) p) + len;
> + p = ((char *) p) + size;
> }
>
> if (g.mode == READING)
> @@ -914,24 +907,18 @@ formatted_transfer_scalar (bt type, void
> }
>
> static void
> -formatted_transfer (bt type, void *p, int len, size_t nelems)
> +formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
> {
> size_t elem;
> - int size;
> char *tmp;
>
> tmp = (char *) p;
>
> - if (type == BT_COMPLEX)
> - size = 2 * len;
> - else
> - size = len;
> -
> /* Big loop over all the elements. */
> for (elem = 0; elem < nelems; elem++)
> {
> g.item_count++;
> - formatted_transfer_scalar (type, tmp + size*elem, len);
> + formatted_transfer_scalar (type, tmp + size*elem, kind, size);
> }
> }
>
> @@ -946,16 +933,22 @@ transfer_integer (void *p, int kind)
> {
> if (ioparm.library_return != LIBRARY_OK)
> return;
> - transfer (BT_INTEGER, p, kind, 1);
> + transfer (BT_INTEGER, p, kind, kind, 1);
> }
>
>
> void
> transfer_real (void *p, int kind)
> {
> + size_t size;
> if (ioparm.library_return != LIBRARY_OK)
> return;
> - transfer (BT_REAL, p, kind, 1);
> + size = kind;
> +#ifdef HAVE_GFC_REAL_10
> + if (kind == 10)
> + size = sizeof (GFC_REAL_10);
> +#endif
> + transfer (BT_REAL, p, kind, size, 1);
> }
>
>
> @@ -964,7 +957,7 @@ transfer_logical (void *p, int kind)
> {
> if (ioparm.library_return != LIBRARY_OK)
> return;
> - transfer (BT_LOGICAL, p, kind, 1);
> + transfer (BT_LOGICAL, p, kind, kind, 1);
> }
>
>
> @@ -973,26 +966,35 @@ transfer_character (void *p, int len)
> {
> if (ioparm.library_return != LIBRARY_OK)
> return;
> - transfer (BT_CHARACTER, p, len, 1);
> + /* Currently we support only 1 byte chars, and the library is a bit
> + confused of character kind vs. length, so we kludge it by setting
> + kind = length. */
> + transfer (BT_CHARACTER, p, len, len, 1);
> }
>
>
> void
> transfer_complex (void *p, int kind)
> {
> + size_t size;
> if (ioparm.library_return != LIBRARY_OK)
> return;
> - transfer (BT_COMPLEX, p, kind, 1);
> + size = 2 * kind;
> +#ifdef HAVE_GFC_COMPLEX_10
> + if (kind == 10)
> + size = sizeof (GFC_COMPLEX_10);
> +#endif
> + transfer (BT_COMPLEX, p, kind, size, 1);
> }
>
>
> void
> -transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
> +transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
> {
> index_type count[GFC_MAX_DIMENSIONS];
> index_type extent[GFC_MAX_DIMENSIONS];
> index_type stride[GFC_MAX_DIMENSIONS];
> - index_type stride0, rank, size, type, n, kind;
> + index_type stride0, rank, size, type, n;
> size_t tsize;
> char *data;
> bt iotype;
> @@ -1002,7 +1004,6 @@ transfer_array (gfc_array_char *desc, gf
>
> type = GFC_DESCRIPTOR_TYPE (desc);
> size = GFC_DESCRIPTOR_SIZE (desc);
> - kind = size;
>
> /* FIXME: What a kludge: Array descriptors and the IO library use
> different enums for types. */
> @@ -1022,7 +1023,6 @@ transfer_array (gfc_array_char *desc, gf
> break;
> case GFC_DTYPE_COMPLEX:
> iotype = BT_COMPLEX;
> - kind /= 2;
> break;
> case GFC_DTYPE_CHARACTER:
> iotype = BT_CHARACTER;
> @@ -1070,7 +1070,7 @@ transfer_array (gfc_array_char *desc, gf
>
> while (data)
> {
> - transfer (iotype, data, kind, tsize);
> + transfer (iotype, data, kind, size, tsize);
> data += stride0 * size * tsize;
> count[0] += tsize;
> n = 0;
> @@ -1447,7 +1447,7 @@ data_transfer_init (int read_flag)
> /* Start the data transfer if we are doing a formatted transfer. */
> if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
> && ioparm.namelist_name == NULL && ionml == NULL)
> - formatted_transfer (0, NULL, 0, 1);
> + formatted_transfer (0, NULL, 0, 0, 1);
> }
>
>
> @@ -1774,16 +1774,13 @@ finalize_transfer (void)
> data transfer, it just updates the length counter. */
>
> static void
> -iolength_transfer (bt type, void *dest __attribute__ ((unused)),
> - int len, size_t nelems)
> +iolength_transfer (bt type __attribute__((unused)),
> + void *dest __attribute__ ((unused)),
> + int kind __attribute__((unused)),
> + size_t size, size_t nelems)
> {
> if (ioparm.iolength != NULL)
> - {
> - if (type == BT_COMPLEX)
> - *ioparm.iolength += 2 * len * nelems;
> - else
> - *ioparm.iolength += len * nelems;
> - }
> + *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
> }
>
>
> Index: libgfortran/io/write.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/write.c,v
> retrieving revision 1.51
> diff -p -u -r1.51 write.c
> --- libgfortran/io/write.c 7 Oct 2005 17:01:48 -0000 1.51
> +++ libgfortran/io/write.c 11 Oct 2005 05:33:04 -0000
> @@ -1396,13 +1396,22 @@ write_real (const char *source, int leng
> static void
> write_complex (const char *source, int len)
> {
> + size_t size;
> +
> + size = len;
> +
> +#ifdef HAVE_GFC_COMPLEX_10
> + if (len == 10)
> + size = sizeof (GFC_COMPLEX_10) / 2;
> +#endif
> +
> if (write_char ('('))
> return;
> write_real (source, len);
>
> if (write_char (','))
> return;
> - write_real (source + len, len);
> + write_real (source + size, len);
>
> write_char (')');
> }
> @@ -1474,24 +1483,18 @@ list_formatted_write_scalar (bt type, vo
>
>
> void
> -list_formatted_write (bt type, void *p, int len, size_t nelems)
> +list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
> {
> size_t elem;
> - int size;
> char *tmp;
>
> tmp = (char *) p;
>
> - if (type == BT_COMPLEX)
> - size = 2 * len;
> - else
> - size = len;
> -
> /* Big loop over all the elements. */
> for (elem = 0; elem < nelems; elem++)
> {
> g.item_count++;
> - list_formatted_write_scalar (type, tmp + size*elem, len);
> + list_formatted_write_scalar (type, tmp + size*elem, kind);
> }
> }
>
> ! { dg-do run }
> ! PR 24174
> program kind10_io
> real(kind=10) :: a,b(2), c
> complex(kind=10) :: d, e, f(2)
> character(len=180) :: tmp
> ! Test real(10) scalar and array formatted IO
> b(:) = 2.0_10
> write (tmp, *) b
> read (tmp, *) a, c
> if (a /= 2.0_10) call abort()
> if (c /= 2.0_10) call abort()
> ! Complex(10) scalar and array formatted and list formatted IO
> f = cmplx ( 1.0_10, 2.0_10, 10)
> d = cmplx ( huge (1.0_10), huge (2.0_10), 10)
> write (tmp, *) d
> ! read (tmp, *) e ! List formatted read doesn't work.
> ! if (e /= d) call abort()
> write (tmp, '(2(e12.4e5, 2x))') d
> ! read (tmp, '(2(e12.4e5, 2x))') e ! Read doesn't work either
> ! if (e /= d) call abort()
> end program kind10_io
--
Janne Blomqvist
More information about the Fortran
mailing list