[Patch, fortran] PR24174 real(10) and complex(10) array IO broken.
Janne Blomqvist
jblomqvi@cc.hut.fi
Tue Oct 11 12:01:00 GMT 2005
: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
-------------- next part --------------
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.
-------------- next part --------------
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);
}
}
-------------- next part --------------
! { 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
More information about the Fortran
mailing list