OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gfortran ChangeLog

Browse Source 
2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	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.

testsuite ChangeLog:

2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	PR fortran/24174
	PR fortran/24305
	* testsuite/gfortran.dg/large_real_kind_form_io_1.f90: New file.

libgfortran Changelog:

2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	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.

From-SVN: r106563
This commit is contained in:
Janne Blomqvist 2005-11-06 20:28:22 +02:00
parent db3d5328dd
commit e5ef4b3bcb
13 changed files with 492 additions and 516 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2005-11-06 Janne Blomqvist <jb@gcc.gnu.org>
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.
2005-11-06 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* intrinsic.c (add_functions): Add ctime and fdate intrinsics.

10
gcc/fortran/trans-io.c
View File

@ -159,10 +159,12 @@ gfc_build_io_library_fndecls (void)
{
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 @@ 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_c_int_type_node,
gfc_charlen_type_node);
/* Library entry points */
@ -1597,14 +1600,17 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
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);

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2005-11-06 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/24174
PR fortran/24305
* testsuite/gfortran.dg/large_real_kind_form_io_1.f90: New file.
2005-11-06 Diego Novillo <dnovillo@redhat.com>
PR 24670

27
gcc/testsuite/gfortran.dg/large_real_kind_form_io_1.f90 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! PR 24174 and PR 24305
program large_real_kind_form_io_1
! This should be 10 on systems that support kind=10
integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1)
real(kind=k) :: a,b(2), c, eps
complex(kind=k) :: d, e, f(2), g
character(len=180) :: tmp
! Test real(k) scalar and array formatted IO
eps = 10 * spacing (2.0_k) ! 10 ulp precision is enough.
b(:) = 2.0_k
write (tmp, *) b
read (tmp, *) a, c
if (abs (a - b(1)) > eps) call abort ()
if (abs (c - b(2)) > eps) 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 (abs (e - d) > eps) call abort ()
if (abs (g - d) > eps) call abort ()
write (tmp, '(2(e12.4e5, 2x))') d
read (tmp, '(2(e12.4e5, 2x))') e
if (abs (e - d) > eps) call abort()
end program large_real_kind_form_io_1

35
libgfortran/ChangeLog
View File

@ -1,3 +1,38 @@
2005-11-06 Janne Blomqvist <jb@gcc.gnu.org>
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.
2005-11-06 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* intrinsics/ctime.c: New file.

1
libgfortran/Makefile.am
View File

@ -27,6 +27,7 @@ io/list_read.c \
io/lock.c \
io/open.c \
io/read.c \
io/size_from_kind.c \
io/transfer.c \
io/unit.c \
io/unix.c \

8
libgfortran/Makefile.in
View File

@ -162,8 +162,8 @@ am__objects_31 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \
$(am__objects_26) $(am__objects_27) $(am__objects_28) \
$(am__objects_29) $(am__objects_30)
am__objects_32 = close.lo file_pos.lo format.lo inquire.lo \
list_read.lo lock.lo open.lo read.lo transfer.lo unit.lo \
unix.lo write.lo
list_read.lo lock.lo open.lo read.lo size_from_kind.lo \
transfer.lo unit.lo unix.lo write.lo
am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
c99_functions.lo chdir.lo cpu_time.lo cshift0.lo ctime.lo \
date_and_time.lo env.lo erf.lo eoshift0.lo eoshift2.lo \
@ -368,6 +368,7 @@ io/list_read.c \
io/lock.c \
io/open.c \
io/read.c \
io/size_from_kind.c \
io/transfer.c \
io/unit.c \
io/unix.c \
@ -2200,6 +2201,9 @@ open.lo: io/open.c
read.lo: io/read.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o read.lo `test -f 'io/read.c' || echo '$(srcdir)/'`io/read.c
size_from_kind.lo: io/size_from_kind.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c
transfer.lo: io/transfer.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o transfer.lo `test -f 'io/transfer.c' || echo '$(srcdir)/'`io/transfer.c

614
libgfortran/configure vendored
View File

File diff suppressed because it is too large Load Diff

11
libgfortran/io/io.h
View File

@ -627,7 +627,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);
@ -680,11 +680,18 @@ 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 */
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

52
libgfortran/io/list_read.c
View File

@ -958,7 +958,7 @@ parse_real (void *buffer, int length)
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 @@ read_complex (int length)
}
eat_spaces ();
if (parse_real (value, length))
if (parse_real (value, kind))
return;
eol_1:
@ -1004,7 +1004,7 @@ eol_2:
else
unget_char (c);
if (parse_real (value + length, length))
if (parse_real (value + size / 2, kind))
return;
eat_spaces ();
@ -1287,7 +1287,7 @@ check_type (bt type, int len)
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 @@ list_formatted_read_scalar (bt type, void *p, int len)
if (repeat_count > 0)
{
if (check_type (type, len))
if (check_type (type, kind))
return;
goto set_value;
}
@ -1348,26 +1348,26 @@ list_formatted_read_scalar (bt type, void *p, int len)
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 @@ list_formatted_read_scalar (bt type, void *p, int len)
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 @@ list_formatted_read_scalar (bt type, void *p, int len)
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 @@ nml_read_obj (namelist_info * nl, index_type offset)
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 @@ nml_read_obj (namelist_info * nl, index_type offset)
break;
case GFC_DTYPE_COMPLEX:
read_complex (len);
read_complex (len, dlen);
break;
case GFC_DTYPE_DERIVED:

88
libgfortran/io/size_from_kind.c Normal file
View File

@ -0,0 +1,88 @@
/* 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;
}
}

93
libgfortran/io/transfer.c
View File

@ -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 * nbytes)
/* 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 @@ require_type (bt expected, bt actual, fnode * f)
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 *p, int len)
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 *p, int len)
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 *p, int len)
}
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 @@ 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 = size_from_real_kind (kind);
transfer (BT_REAL, p, kind, size, 1);
}
@ -964,7 +953,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 +962,31 @@ 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 = 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 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
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 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
break;
case GFC_DTYPE_COMPLEX:
iotype = BT_COMPLEX;
kind /= 2;
break;
case GFC_DTYPE_CHARACTER:
iotype = BT_CHARACTER;
@ -1070,7 +1062,7 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
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 @@ 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);
}
/* Initialize an array_loop_spec given the array descriptor. The function
@ -1862,16 +1854,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;
}

55
libgfortran/io/write.c
View File

@ -1394,15 +1394,15 @@ write_real (const char *source, int length)
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 @@ write_separator (void)
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 @@ list_formatted_write_scalar (bt type, void *p, int len)
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 @@ list_formatted_write_scalar (bt type, void *p, int len)
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 @@ nml_write_obj (namelist_info * obj, index_type offset,
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 @@ nml_write_obj (namelist_info * obj, index_type offset,
case GFC_DTYPE_COMPLEX:
no_leading_blank = 0;
num++;
write_complex (p, len);
write_complex (p, len, obj_size);
break;
case GFC_DTYPE_DERIVED: