[Patch, fortran] PR24174 real(10) and complex(10) array IO broken.
Janne Blomqvist
jblomqvi@cc.hut.fi
Sat Nov 5 16:33:00 GMT 2005
On Tue, Oct 25, 2005 at 12:49:34PM +0200, FX Coudert wrote:
> >PING**2
>
> It looks OK. Only one comment...
>
> 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);
>
> contradicts
>
> void
> -transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
> +transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
>
> since a gfc_int4_type_node might not always be an int. Could you use
> gfc_c_int_type_node?
Ok, here is an updated patch, fixing the above issue. While I was at
it, I also made formatted complex(10) input work in addition to output
(i.e. fixing PR 24305 as well). I also made a couple of utility
functions for determining the size from the kind, and put them in
their own file.
However, there is still some kind of issue with formatted input of
very big real(10) numbers. But AFAICS that has to do with parsing and
not with the padding issues that this patch tries to address, so I'll
file a separate PR for that.
--
Janne Blomqvist
-------------- next part --------------
gfortran ChangeLog
2005-11-05 Janne Blomqvist <jblomqvi@cc.hut.fi>
PR fortran/24174
PR fortran/24305
* fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
argument to transfer_array.
(transfer_array_desc): Add kind argument.
libgfortran Changelog:
2005-11-05 Janne Blomqvist <jblomqvi@cc.hut.fi>
PR fortran/24174
PR fortran/24305
* io/io.h: Add argument to prototypes, add prototypes for
size_from_*_kind functions.
* io/list_read.c (read_complex): Add size argument, use
it.
(list_formatted_read): Add size argument, cleanup.
(list_formatted_read_scalar): Add size argument.
(nml_read_obj): Fix for padding.
* 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): Add size argument, fix for padding
with complex(10).
(list_formatted_write): Add size argument, cleanup.
(list_formatted_write_scalar): Add size argument, use it.
(nml_write_obj): Fix for size vs. kind issue.
* io/size_from_kind.c: New file.
* Makefile.am: Add io/size_from_kind.c.
* configure: Regenerate.
* Makefile.in: Regenerate.
* aclocal.m4: Regenerate.
-------------- next part --------------
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 106527)
+++ gcc/fortran/trans-io.c (working copy)
@@ -159,10 +159,12 @@
{
tree gfc_int4_type_node;
tree gfc_pint4_type_node;
+ tree gfc_c_int_type_node;
tree ioparm_type;
gfc_int4_type_node = gfc_get_int_type (4);
gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
+ gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
/* Build the st_parameter structure. Information associated with I/O
calls are transferred here. This must match the one defined in the
@@ -271,7 +273,8 @@
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_c_int_type_node,
gfc_charlen_type_node);
/* Library entry points */
@@ -1597,14 +1600,17 @@
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/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 106527)
+++ libgfortran/io/transfer.c (working copy)
@@ -78,7 +78,7 @@
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 void (*transfer) (bt, void *, int, size_t);
+static void (*transfer) (bt, void *, int, size_t, size_t);
typedef enum
@@ -394,36 +394,26 @@
/* 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;
+ size *= nelems;
- len = length * 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 @@
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 @@
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 @@
if ((consume_data_flag > 0) && (n > 0))
{
n--;
- p = ((char *) p) + len;
+ p = ((char *) p) + size;
}
if (g.mode == READING)
@@ -914,24 +907,18 @@
}
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,18 @@
{
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 = size_from_real_kind (kind);
+ transfer (BT_REAL, p, kind, size, 1);
}
@@ -964,7 +953,7 @@
{
if (ioparm.library_return != LIBRARY_OK)
return;
- transfer (BT_LOGICAL, p, kind, 1);
+ transfer (BT_LOGICAL, p, kind, kind, 1);
}
@@ -973,26 +962,31 @@
{
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 = size_from_complex_kind (kind);
+ 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 +996,6 @@
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 +1015,6 @@
break;
case GFC_DTYPE_COMPLEX:
iotype = BT_COMPLEX;
- kind /= 2;
break;
case GFC_DTYPE_CHARACTER:
iotype = BT_CHARACTER;
@@ -1070,7 +1062,7 @@
while (data)
{
- transfer (iotype, data, kind, tsize);
+ transfer (iotype, data, kind, size, tsize);
data += stride0 * size * tsize;
count[0] += tsize;
n = 0;
@@ -1450,7 +1442,7 @@
/* 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);
}
/* Initialize an array_loop_spec given the array descriptor. The function
@@ -1862,16 +1854,13 @@
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/list_read.c
===================================================================
--- libgfortran/io/list_read.c (revision 106527)
+++ libgfortran/io/list_read.c (working copy)
@@ -958,7 +958,7 @@
what it is right away. */
static void
-read_complex (int length)
+read_complex (int kind, size_t size)
{
char message[100];
char c;
@@ -982,7 +982,7 @@
}
eat_spaces ();
- if (parse_real (value, length))
+ if (parse_real (value, kind))
return;
eol_1:
@@ -1004,7 +1004,7 @@
else
unget_char (c);
- if (parse_real (value + length, length))
+ if (parse_real (value + size / 2, kind))
return;
eat_spaces ();
@@ -1287,7 +1287,7 @@
greater than one, we copy the data item multiple times. */
static void
-list_formatted_read_scalar (bt type, void *p, int len)
+list_formatted_read_scalar (bt type, void *p, int kind, size_t size)
{
char c;
int m;
@@ -1326,7 +1326,7 @@
if (repeat_count > 0)
{
- if (check_type (type, len))
+ if (check_type (type, kind))
return;
goto set_value;
}
@@ -1348,26 +1348,26 @@
switch (type)
{
case BT_INTEGER:
- read_integer (len);
+ read_integer (kind);
break;
case BT_LOGICAL:
- read_logical (len);
+ read_logical (kind);
break;
case BT_CHARACTER:
- read_character (len);
+ read_character (kind);
break;
case BT_REAL:
- read_real (len);
+ read_real (kind);
break;
case BT_COMPLEX:
- read_complex (len);
+ read_complex (kind, size);
break;
default:
internal_error ("Bad type for list read");
}
if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
- saved_length = len;
+ saved_length = size;
if (ioparm.library_return != LIBRARY_OK)
return;
@@ -1376,27 +1376,24 @@
switch (saved_type)
{
case BT_COMPLEX:
- len = 2 * len;
- /* Fall through. */
-
case BT_INTEGER:
case BT_REAL:
case BT_LOGICAL:
- memcpy (p, value, len);
+ memcpy (p, value, size);
break;
case BT_CHARACTER:
if (saved_string)
{
- m = (len < saved_used) ? len : saved_used;
+ m = ((int) size < saved_used) ? (int) size : saved_used;
memcpy (p, saved_string, m);
}
else
/* Just delimiters encountered, nothing to copy but SPACE. */
m = 0;
- if (m < len)
- memset (((char *) p) + m, ' ', len - m);
+ if (m < (int) size)
+ memset (((char *) p) + m, ' ', size - m);
break;
case BT_NULL:
@@ -1409,24 +1406,18 @@
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, size);
}
}
@@ -1862,12 +1853,15 @@
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_LOGICAL:
- case GFC_DTYPE_REAL:
dlen = len;
break;
+ case GFC_DTYPE_REAL:
+ dlen = size_from_real_kind (len);
+ break;
+
case GFC_DTYPE_COMPLEX:
- dlen = 2* len;
+ dlen = size_from_complex_kind (len);
break;
case GFC_DTYPE_CHARACTER:
@@ -1927,7 +1921,7 @@
break;
case GFC_DTYPE_COMPLEX:
- read_complex (len);
+ read_complex (len, dlen);
break;
case GFC_DTYPE_DERIVED:
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c (revision 106527)
+++ libgfortran/io/write.c (working copy)
@@ -1394,15 +1394,15 @@
static void
-write_complex (const char *source, int len)
+write_complex (const char *source, int kind, size_t size)
{
if (write_char ('('))
return;
- write_real (source, len);
+ write_real (source, kind);
if (write_char (','))
return;
- write_real (source + len, len);
+ write_real (source + size / 2, kind);
write_char (')');
}
@@ -1428,7 +1428,7 @@
with strings. */
static void
-list_formatted_write_scalar (bt type, void *p, int len)
+list_formatted_write_scalar (bt type, void *p, int kind, size_t size)
{
static int char_flag;
@@ -1451,19 +1451,19 @@
switch (type)
{
case BT_INTEGER:
- write_integer (p, len);
+ write_integer (p, kind);
break;
case BT_LOGICAL:
- write_logical (p, len);
+ write_logical (p, kind);
break;
case BT_CHARACTER:
- write_character (p, len);
+ write_character (p, kind);
break;
case BT_REAL:
- write_real (p, len);
+ write_real (p, kind);
break;
case BT_COMPLEX:
- write_complex (p, len);
+ write_complex (p, kind, size);
break;
default:
internal_error ("list_formatted_write(): Bad type");
@@ -1474,24 +1474,18 @@
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, size);
}
}
@@ -1573,11 +1567,26 @@
num = 1;
len = obj->len;
- obj_size = len;
- if (obj->type == GFC_DTYPE_COMPLEX)
- obj_size = 2*len;
- if (obj->type == GFC_DTYPE_CHARACTER)
- obj_size = obj->string_length;
+
+ switch (obj->type)
+ {
+
+ case GFC_DTYPE_REAL:
+ obj_size = size_from_real_kind (len);
+ break;
+
+ case GFC_DTYPE_COMPLEX:
+ obj_size = size_from_complex_kind (len);
+ break;
+
+ case GFC_DTYPE_CHARACTER:
+ obj_size = obj->string_length;
+ break;
+
+ default:
+ obj_size = len;
+ }
+
if (obj->var_rank)
obj_size = obj->size;
@@ -1654,7 +1663,7 @@
case GFC_DTYPE_COMPLEX:
no_leading_blank = 0;
num++;
- write_complex (p, len);
+ write_complex (p, len, obj_size);
break;
case GFC_DTYPE_DERIVED:
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 106527)
+++ libgfortran/io/io.h (working copy)
@@ -627,7 +627,7 @@
/* 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);
@@ -680,11 +680,18 @@
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 */
extern try notify_std (int, const char *);
internal_proto(notify_std);
+/* size_from_kind.c */
+extern size_t size_from_real_kind (int);
+internal_proto(size_from_real_kind);
+
+extern size_t size_from_complex_kind (int);
+internal_proto(size_from_complex_kind);
+
#endif
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 106527)
+++ libgfortran/Makefile.am (working copy)
@@ -27,6 +27,7 @@
io/lock.c \
io/open.c \
io/read.c \
+io/size_from_kind.c \
io/transfer.c \
io/unit.c \
io/unix.c \
-------------- next part --------------
/* Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by Janne Blomqvist
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
/* This file contains utility functions for determining the size of a
variable given its kind. */
#include "io.h"
size_t
size_from_real_kind (int kind)
{
switch (kind)
{
#ifdef HAVE_GFC_REAL_4
case 4:
return sizeof (GFC_REAL_4);
#endif
#ifdef HAVE_GFC_REAL_8
case 8:
return sizeof (GFC_REAL_8);
#endif
#ifdef HAVE_GFC_REAL_10
case 10:
return sizeof (GFC_REAL_10);
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
return sizeof (GFC_REAL_16);
#endif
default:
return kind;
}
}
size_t
size_from_complex_kind (int kind)
{
switch (kind)
{
#ifdef HAVE_GFC_COMPLEX_4
case 4:
return sizeof (GFC_COMPLEX_4);
#endif
#ifdef HAVE_GFC_COMPLEX_8
case 8:
return sizeof (GFC_COMPLEX_8);
#endif
#ifdef HAVE_GFC_COMPLEX_10
case 10:
return sizeof (GFC_COMPLEX_10);
#endif
#ifdef HAVE_GFC_COMPLEX_16
case 16:
return sizeof (GFC_COMPLEX_16);
#endif
default:
return 2 * kind;
}
}
-------------- next part --------------
! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! PR 24174 and PR 24305
program kind10_formatted_io
! This should be kind=10 on systems that support it
integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1)
real(kind=k) :: a,b(2), c
complex(kind=k) :: d, e, f(2), g
character(len=180) :: tmp
! Test real(k) scalar and array formatted IO
b(:) = 2.0_k
write (tmp, *) b
read (tmp, *) a, c
if (a /= b(1)) call abort ()
if (c /= b(2)) call abort ()
! Complex(k) scalar and array formatted and list formatted IO
d = cmplx ( 1.0_k, 2.0_k, k)
f = d
write (tmp, *) f
read (tmp, *) e, g
if (e /= d) call abort ()
if (g /= d) call abort ()
write (tmp, '(2(e12.4e5, 2x))') d
read (tmp, '(2(e12.4e5, 2x))') e
if (e /= d) call abort()
end program kind10_formatted_io
More information about the Fortran
mailing list