[multiple changes]
2005-09-24 Janne Blomqvist <jblomqvi@cc.hut.fi>
* trans-io.c (gfc_build_io_library_fndecls): Add entry
iocall_x_array for transfer_array. (transfer_array_desc): New
function. (gfc_trans_transfer): Add code to call
transfer_array_desc.
2005-09-24 Janne Blomqvist <jblomqvi@cc.hut.fi>
* io.h: Changed prototypes of list_formatted_{read|write}.
* list_read.c (list_formatted_read): Renamed to
list_formatted_read_scalar and made static. (list_formatted_read):
New function.
* transfer.c: Prototype for transfer_array. Changed transfer
function pointer. (unformatted_read): Add nelems argument, use
it. (unformatted_write): Likewise. (formatted_transfer): Changed
name to formatted_transfer_scalar. (formatted_transfer): New
function. (transfer_integer): Add nelems argument to transfer
call, move updating item count to transfer
functions. (transfer_real): Likewise. (transfer_logical):
Likewise. (transfer_character): Likewise. (transfer_complex):
Likewise. (transfer_array): New function. (data_transfer_init):
Call formatted_transfer with new argument. (iolength_transfer):
New argument, use it.
* write.c (list_formatted_write): Renamed to
list_formatted_write_scalar, made static. (list_formatted_write):
New function.
From-SVN: r104662
This commit is contained in:
Janne Blomqvist
Bud Davis
parent
d05d9ac771
commit
18623faed1
7 changed files with 281 additions and 34 deletions
|
|
@ -1,3 +1,10 @@
|
|||
2005-09-24 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* trans-io.c (gfc_build_io_library_fndecls): Add entry
|
||||
iocall_x_array for transfer_array. (transfer_array_desc): New
|
||||
function. (gfc_trans_transfer): Add code to call
|
||||
transfer_array_desc.
|
||||
|
||||
2005-09-26 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR fortran/23677
|
||||
|
|
|
|||
|
|
@ -120,6 +120,7 @@ static GTY(()) tree iocall_x_logical;
|
|||
static GTY(()) tree iocall_x_character;
|
||||
static GTY(()) tree iocall_x_real;
|
||||
static GTY(()) tree iocall_x_complex;
|
||||
static GTY(()) tree iocall_x_array;
|
||||
static GTY(()) tree iocall_open;
|
||||
static GTY(()) tree iocall_close;
|
||||
static GTY(()) tree iocall_inquire;
|
||||
|
|
@ -267,6 +268,12 @@ gfc_build_io_library_fndecls (void)
|
|||
void_type_node, 2, pvoid_type_node,
|
||||
gfc_int4_type_node);
|
||||
|
||||
iocall_x_array =
|
||||
gfc_build_library_function_decl (get_identifier
|
||||
(PREFIX("transfer_array")),
|
||||
void_type_node, 2, pvoid_type_node,
|
||||
gfc_charlen_type_node);
|
||||
|
||||
/* Library entry points */
|
||||
|
||||
iocall_read =
|
||||
|
|
@ -1584,6 +1591,27 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
|||
}
|
||||
|
||||
|
||||
/* Generate a call to pass an array descriptor to the IO library. The
|
||||
array should be of one of the intrinsic types. */
|
||||
|
||||
static void
|
||||
transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
||||
{
|
||||
tree args, tmp, charlen_arg;
|
||||
|
||||
if (ts->type == BT_CHARACTER)
|
||||
charlen_arg = se->string_length;
|
||||
else
|
||||
charlen_arg = build_int_cstu (NULL_TREE, 0);
|
||||
|
||||
args = gfc_chainon_list (NULL_TREE, addr_expr);
|
||||
args = gfc_chainon_list (args, charlen_arg);
|
||||
tmp = gfc_build_function_call (iocall_x_array, args);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
gfc_add_block_to_block (&se->pre, &se->post);
|
||||
}
|
||||
|
||||
|
||||
/* gfc_trans_transfer()-- Translate a TRANSFER code node */
|
||||
|
||||
tree
|
||||
|
|
@ -1597,6 +1625,7 @@ gfc_trans_transfer (gfc_code * code)
|
|||
tree tmp;
|
||||
|
||||
gfc_start_block (&block);
|
||||
gfc_init_block (&body);
|
||||
|
||||
expr = code->expr;
|
||||
ss = gfc_walk_expr (expr);
|
||||
|
|
@ -1604,8 +1633,11 @@ gfc_trans_transfer (gfc_code * code)
|
|||
gfc_init_se (&se, NULL);
|
||||
|
||||
if (ss == gfc_ss_terminator)
|
||||
gfc_init_block (&body);
|
||||
else
|
||||
{
|
||||
gfc_conv_expr_reference (&se, expr);
|
||||
transfer_expr (&se, &expr->ts, se.expr);
|
||||
}
|
||||
else if (expr->ts.type == BT_DERIVED)
|
||||
{
|
||||
/* Initialize the scalarizer. */
|
||||
gfc_init_loopinfo (&loop);
|
||||
|
|
@ -1621,11 +1653,17 @@ gfc_trans_transfer (gfc_code * code)
|
|||
|
||||
gfc_copy_loopinfo_to_se (&se, &loop);
|
||||
se.ss = ss;
|
||||
|
||||
gfc_conv_expr_reference (&se, expr);
|
||||
transfer_expr (&se, &expr->ts, se.expr);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Pass the array descriptor to the library. */
|
||||
gfc_conv_expr_descriptor (&se, expr, ss);
|
||||
tmp = gfc_build_addr_expr (NULL, se.expr);
|
||||
transfer_array_desc (&se, &expr->ts, tmp);
|
||||
}
|
||||
|
||||
gfc_conv_expr_reference (&se, expr);
|
||||
|
||||
transfer_expr (&se, &expr->ts, se.expr);
|
||||
|
||||
gfc_add_block_to_block (&body, &se.pre);
|
||||
gfc_add_block_to_block (&body, &se.post);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,24 @@
|
|||
2005-09-24 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* io.h: Changed prototypes of list_formatted_{read|write}.
|
||||
* list_read.c (list_formatted_read): Renamed to
|
||||
list_formatted_read_scalar and made static. (list_formatted_read):
|
||||
New function.
|
||||
* transfer.c: Prototype for transfer_array. Changed transfer
|
||||
function pointer. (unformatted_read): Add nelems argument, use
|
||||
it. (unformatted_write): Likewise. (formatted_transfer): Changed
|
||||
name to formatted_transfer_scalar. (formatted_transfer): New
|
||||
function. (transfer_integer): Add nelems argument to transfer
|
||||
call, move updating item count to transfer
|
||||
functions. (transfer_real): Likewise. (transfer_logical):
|
||||
Likewise. (transfer_character): Likewise. (transfer_complex):
|
||||
Likewise. (transfer_array): New function. (data_transfer_init):
|
||||
Call formatted_transfer with new argument. (iolength_transfer):
|
||||
New argument, use it.
|
||||
* write.c (list_formatted_write): Renamed to
|
||||
list_formatted_write_scalar, made static. (list_formatted_write):
|
||||
New function.
|
||||
|
||||
2005-09-26 David Edelsohn <dje@watson.ibm.com>
|
||||
|
||||
* configure.ac: Add check for __clog.
|
||||
|
|
|
|||
|
|
@ -613,7 +613,7 @@ internal_proto(read_decimal);
|
|||
|
||||
/* list_read.c */
|
||||
|
||||
extern void list_formatted_read (bt, void *, int);
|
||||
extern void list_formatted_read (bt, void *, int, size_t);
|
||||
internal_proto(list_formatted_read);
|
||||
|
||||
extern void finish_list_read (void);
|
||||
|
|
@ -666,7 +666,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);
|
||||
extern void list_formatted_write (bt, void *, int, size_t);
|
||||
internal_proto(list_formatted_write);
|
||||
|
||||
/* error.c */
|
||||
|
|
|
|||
|
|
@ -1285,8 +1285,8 @@ check_type (bt type, int len)
|
|||
reading, usually in the value[] array. If a repeat count is
|
||||
greater than one, we copy the data item multiple times. */
|
||||
|
||||
void
|
||||
list_formatted_read (bt type, void *p, int len)
|
||||
static void
|
||||
list_formatted_read_scalar (bt type, void *p, int len)
|
||||
{
|
||||
char c;
|
||||
int m;
|
||||
|
|
@ -1406,6 +1406,30 @@ list_formatted_read (bt type, void *p, int len)
|
|||
free_saved ();
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
list_formatted_read (bt type, void *p, int len, 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);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
init_at_eol(void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -78,6 +78,9 @@ export_proto(transfer_character);
|
|||
extern void transfer_complex (void *, int);
|
||||
export_proto(transfer_complex);
|
||||
|
||||
extern void transfer_array (gfc_array_char *, gfc_charlen_type);
|
||||
export_proto(transfer_array);
|
||||
|
||||
gfc_unit *current_unit = NULL;
|
||||
static int sf_seen_eor = 0;
|
||||
static int eor_condition = 0;
|
||||
|
|
@ -101,7 +104,7 @@ static st_option advance_opt[] = {
|
|||
};
|
||||
|
||||
|
||||
static void (*transfer) (bt, void *, int);
|
||||
static void (*transfer) (bt, void *, int, size_t);
|
||||
|
||||
|
||||
typedef enum
|
||||
|
|
@ -312,11 +315,13 @@ write_block (int length)
|
|||
/* Master function for unformatted reads. */
|
||||
|
||||
static void
|
||||
unformatted_read (bt type, void *dest, int length)
|
||||
unformatted_read (bt type, void *dest, int length, size_t nelems)
|
||||
{
|
||||
void *source;
|
||||
int w;
|
||||
|
||||
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. */
|
||||
|
|
@ -337,17 +342,20 @@ unformatted_read (bt type, void *dest, int length)
|
|||
/* Master function for unformatted writes. */
|
||||
|
||||
static void
|
||||
unformatted_write (bt type, void *source, int length)
|
||||
unformatted_write (bt type, void *source, int length, size_t nelems)
|
||||
{
|
||||
void *dest;
|
||||
size_t len;
|
||||
|
||||
len = length * nelems;
|
||||
|
||||
/* Correction for kind vs. length as in unformatted_read. */
|
||||
if (type == BT_COMPLEX)
|
||||
length *= 2;
|
||||
len *= 2;
|
||||
|
||||
dest = write_block (length);
|
||||
dest = write_block (len);
|
||||
if (dest != NULL)
|
||||
memcpy (dest, source, length);
|
||||
memcpy (dest, source, len);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -442,7 +450,7 @@ require_type (bt expected, bt actual, fnode * f)
|
|||
of the next element, then comes back here to process it. */
|
||||
|
||||
static void
|
||||
formatted_transfer (bt type, void *p, int len)
|
||||
formatted_transfer_scalar (bt type, void *p, int len)
|
||||
{
|
||||
int pos, bytes_used;
|
||||
fnode *f;
|
||||
|
|
@ -837,6 +845,29 @@ formatted_transfer (bt type, void *p, int len)
|
|||
unget_format (f);
|
||||
}
|
||||
|
||||
static void
|
||||
formatted_transfer (bt type, void *p, int len, 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);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Data transfer entry points. The type of the data entity is
|
||||
implicit in the subroutine call. This prevents us from having to
|
||||
|
|
@ -845,50 +876,153 @@ formatted_transfer (bt type, void *p, int len)
|
|||
void
|
||||
transfer_integer (void *p, int kind)
|
||||
{
|
||||
g.item_count++;
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
transfer (BT_INTEGER, p, kind);
|
||||
transfer (BT_INTEGER, p, kind, 1);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
transfer_real (void *p, int kind)
|
||||
{
|
||||
g.item_count++;
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
transfer (BT_REAL, p, kind);
|
||||
transfer (BT_REAL, p, kind, 1);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
transfer_logical (void *p, int kind)
|
||||
{
|
||||
g.item_count++;
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
transfer (BT_LOGICAL, p, kind);
|
||||
transfer (BT_LOGICAL, p, kind, 1);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
transfer_character (void *p, int len)
|
||||
{
|
||||
g.item_count++;
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
transfer (BT_CHARACTER, p, len);
|
||||
transfer (BT_CHARACTER, p, len, 1);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
transfer_complex (void *p, int kind)
|
||||
{
|
||||
g.item_count++;
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
transfer (BT_COMPLEX, p, kind);
|
||||
transfer (BT_COMPLEX, p, kind, 1);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
transfer_array (gfc_array_char *desc, 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;
|
||||
size_t tsize;
|
||||
char *data;
|
||||
bt iotype;
|
||||
|
||||
if (ioparm.library_return != LIBRARY_OK)
|
||||
return;
|
||||
|
||||
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. */
|
||||
switch (type)
|
||||
{
|
||||
case GFC_DTYPE_UNKNOWN:
|
||||
iotype = BT_NULL; /* Is this correct? */
|
||||
break;
|
||||
case GFC_DTYPE_INTEGER:
|
||||
iotype = BT_INTEGER;
|
||||
break;
|
||||
case GFC_DTYPE_LOGICAL:
|
||||
iotype = BT_LOGICAL;
|
||||
break;
|
||||
case GFC_DTYPE_REAL:
|
||||
iotype = BT_REAL;
|
||||
break;
|
||||
case GFC_DTYPE_COMPLEX:
|
||||
iotype = BT_COMPLEX;
|
||||
kind /= 2;
|
||||
break;
|
||||
case GFC_DTYPE_CHARACTER:
|
||||
iotype = BT_CHARACTER;
|
||||
/* FIXME: Currently dtype contains the charlen, which is
|
||||
clobbered if charlen > 2**24. That's why we use a separate
|
||||
argument for the charlen. However, if we want to support
|
||||
non-8-bit charsets we need to fix dtype to contain
|
||||
sizeof(chartype) and fix the code below. */
|
||||
size = charlen;
|
||||
kind = charlen;
|
||||
break;
|
||||
case GFC_DTYPE_DERIVED:
|
||||
internal_error ("Derived type I/O should have been handled via the frontend.");
|
||||
break;
|
||||
default:
|
||||
internal_error ("transfer_array(): Bad type");
|
||||
}
|
||||
|
||||
if (desc->dim[0].stride == 0)
|
||||
desc->dim[0].stride = 1;
|
||||
|
||||
rank = GFC_DESCRIPTOR_RANK (desc);
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
stride[n] = desc->dim[n].stride;
|
||||
extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
|
||||
|
||||
/* If the extent of even one dimension is zero, then the entire
|
||||
array section contains zero elements, so we return. */
|
||||
if (extent[n] == 0)
|
||||
return;
|
||||
}
|
||||
|
||||
stride0 = stride[0];
|
||||
|
||||
/* If the innermost dimension has stride 1, we can do the transfer
|
||||
in contiguous chunks. */
|
||||
if (stride0 == 1)
|
||||
tsize = extent[0];
|
||||
else
|
||||
tsize = 1;
|
||||
|
||||
data = GFC_DESCRIPTOR_DATA (desc);
|
||||
|
||||
while (data)
|
||||
{
|
||||
transfer (iotype, data, kind, tsize);
|
||||
data += stride0 * size * tsize;
|
||||
count[0] += tsize;
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
data -= stride[n] * extent[n] * size;
|
||||
n++;
|
||||
if (n == rank)
|
||||
{
|
||||
data = NULL;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
data += stride[n] * size;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1245,7 +1379,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);
|
||||
formatted_transfer (0, NULL, 0, 1);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1568,15 +1702,15 @@ finalize_transfer (void)
|
|||
data transfer, it just updates the length counter. */
|
||||
|
||||
static void
|
||||
iolength_transfer (bt type , void *dest __attribute__ ((unused)),
|
||||
int len)
|
||||
iolength_transfer (bt type, void *dest __attribute__ ((unused)),
|
||||
int len, size_t nelems)
|
||||
{
|
||||
if (ioparm.iolength != NULL)
|
||||
{
|
||||
if (type == BT_COMPLEX)
|
||||
*ioparm.iolength += 2*len;
|
||||
*ioparm.iolength += 2 * len * nelems;
|
||||
else
|
||||
*ioparm.iolength += len;
|
||||
*ioparm.iolength += len * nelems;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1423,8 +1423,8 @@ write_separator (void)
|
|||
TODO: handle skipping to the next record correctly, particularly
|
||||
with strings. */
|
||||
|
||||
void
|
||||
list_formatted_write (bt type, void *p, int len)
|
||||
static void
|
||||
list_formatted_write_scalar (bt type, void *p, int len)
|
||||
{
|
||||
static int char_flag;
|
||||
|
||||
|
|
@ -1468,6 +1468,29 @@ list_formatted_write (bt type, void *p, int len)
|
|||
char_flag = (type == BT_CHARACTER);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
list_formatted_write (bt type, void *p, int len, 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);
|
||||
}
|
||||
}
|
||||
|
||||
/* NAMELIST OUTPUT
|
||||
|
||||
nml_write_obj writes a namelist object to the output stream. It is called
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue