re PR fortran/15750 (IOLENGTH form of INQUIRE statement not implemented)
PR fortran/15750 * io.c (gfc_match_inquire): Bugfix for iolength related stuff. (gfc_resolve_inquire): Resolve the iolength tag. Return SUCCESS at end of function if no failure has occured. * resolve.c (resolve_code): Resolve if iolength is encountered. * trans-io.c: (ioparm_iolength, iocall_iolength, iocall_iolength_done): New variables. (last_dt): Add IOLENGTH. (gfc_build_io_library_fndecls ): Set iolength related variables. (gfc_trans_iolength): Implement. (gfc_trans_dt_end): Treat iolength as a third form of data transfer. libgfortran/ PR fortran/15750 * inquire.c (st_inquire): Add comment * io.h (st_parameter): Add iolength. (st_iolength, st_iolength_done): Declare. * transfer.c (iolength_transfer, iolength_transfer_init, st_iolength, st_iolength_done): New functions. testsuite/ * gfortran.fortran-torture/execute/iolength_1.f90: New test. * gfortran.fortran-torture/execute/iolength_3.f90: New test. From-SVN: r83472
This commit is contained in:
parent
88c499cce7
commit
8750f9cdec
@ -1,3 +1,17 @@
|
||||
2004-06-22 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
PR fortran/15750
|
||||
* io.c (gfc_match_inquire): Bugfix for iolength related stuff.
|
||||
(gfc_resolve_inquire): Resolve the iolength tag. Return
|
||||
SUCCESS at end of function if no failure has occured.
|
||||
* resolve.c (resolve_code): Resolve if iolength is encountered.
|
||||
* trans-io.c: (ioparm_iolength, iocall_iolength,
|
||||
iocall_iolength_done): New variables.
|
||||
(last_dt): Add IOLENGTH.
|
||||
(gfc_build_io_library_fndecls ): Set iolength related variables.
|
||||
(gfc_trans_iolength): Implement.
|
||||
(gfc_trans_dt_end): Treat iolength as a third form of data transfer.
|
||||
|
||||
2004-06-21 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de
|
||||
|
||||
PR fortran/15511
|
||||
|
@ -2353,7 +2353,7 @@ gfc_match_inquire (void)
|
||||
|
||||
new_st.op = EXEC_IOLENGTH;
|
||||
new_st.expr = inquire->iolength;
|
||||
gfc_free (inquire);
|
||||
new_st.ext.inquire = inquire;
|
||||
|
||||
if (gfc_pure (NULL))
|
||||
{
|
||||
@ -2439,9 +2439,10 @@ gfc_resolve_inquire (gfc_inquire * inquire)
|
||||
RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
|
||||
RESOLVE_TAG (&tag_s_delim, inquire->delim);
|
||||
RESOLVE_TAG (&tag_s_pad, inquire->pad);
|
||||
RESOLVE_TAG (&tag_iolength, inquire->iolength);
|
||||
|
||||
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return FAILURE;
|
||||
return SUCCESS;
|
||||
}
|
||||
|
@ -3452,7 +3452,6 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
|
||||
{
|
||||
case EXEC_NOP:
|
||||
case EXEC_CYCLE:
|
||||
case EXEC_IOLENGTH:
|
||||
case EXEC_PAUSE:
|
||||
case EXEC_STOP:
|
||||
case EXEC_EXIT:
|
||||
@ -3619,6 +3618,14 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
|
||||
break;
|
||||
|
||||
case EXEC_INQUIRE:
|
||||
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
||||
break;
|
||||
|
||||
resolve_branch (code->ext.inquire->err, code);
|
||||
break;
|
||||
|
||||
case EXEC_IOLENGTH:
|
||||
assert(code->ext.inquire != NULL);
|
||||
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
|
||||
break;
|
||||
|
||||
|
@ -59,6 +59,7 @@ static GTY(()) tree ioparm_nextrec;
|
||||
static GTY(()) tree ioparm_size;
|
||||
static GTY(()) tree ioparm_recl_in;
|
||||
static GTY(()) tree ioparm_recl_out;
|
||||
static GTY(()) tree ioparm_iolength;
|
||||
static GTY(()) tree ioparm_file;
|
||||
static GTY(()) tree ioparm_file_len;
|
||||
static GTY(()) tree ioparm_status;
|
||||
@ -124,6 +125,8 @@ static GTY(()) tree iocall_x_complex;
|
||||
static GTY(()) tree iocall_open;
|
||||
static GTY(()) tree iocall_close;
|
||||
static GTY(()) tree iocall_inquire;
|
||||
static GTY(()) tree iocall_iolength;
|
||||
static GTY(()) tree iocall_iolength_done;
|
||||
static GTY(()) tree iocall_rewind;
|
||||
static GTY(()) tree iocall_backspace;
|
||||
static GTY(()) tree iocall_endfile;
|
||||
@ -136,7 +139,7 @@ static GTY(()) tree iocall_set_nml_val_log;
|
||||
/* Variable for keeping track of what the last data transfer statement
|
||||
was. Used for deciding which subroutine to call when the data
|
||||
transfer is complete. */
|
||||
static enum { READ, WRITE } last_dt;
|
||||
static enum { READ, WRITE, IOLENGTH } last_dt;
|
||||
|
||||
#define ADD_FIELD(name, type) \
|
||||
ioparm_ ## name = gfc_add_field_to_struct \
|
||||
@ -187,6 +190,8 @@ gfc_build_io_library_fndecls (void)
|
||||
ADD_FIELD (recl_in, gfc_pint4_type_node);
|
||||
ADD_FIELD (recl_out, gfc_pint4_type_node);
|
||||
|
||||
ADD_FIELD (iolength, gfc_pint4_type_node);
|
||||
|
||||
ADD_STRING (file);
|
||||
ADD_STRING (status);
|
||||
|
||||
@ -282,6 +287,10 @@ gfc_build_io_library_fndecls (void)
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
|
||||
gfc_int4_type_node, 0);
|
||||
|
||||
iocall_iolength =
|
||||
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
|
||||
void_type_node, 0);
|
||||
|
||||
iocall_rewind =
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
|
||||
gfc_int4_type_node, 0);
|
||||
@ -302,6 +311,11 @@ gfc_build_io_library_fndecls (void)
|
||||
iocall_write_done =
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
|
||||
gfc_int4_type_node, 0);
|
||||
|
||||
iocall_iolength_done =
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
|
||||
gfc_int4_type_node, 0);
|
||||
|
||||
iocall_set_nml_val_int =
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
|
||||
void_type_node, 4,
|
||||
@ -793,16 +807,6 @@ gfc_trans_inquire (gfc_code * code)
|
||||
}
|
||||
|
||||
|
||||
/* Translate the IOLENGTH form of an INQUIRE statement. We treat
|
||||
this as a third sort of data transfer statement, except that
|
||||
lengths are summed instead of actually transfering any data. */
|
||||
|
||||
tree
|
||||
gfc_trans_iolength (gfc_code * c ATTRIBUTE_UNUSED)
|
||||
{
|
||||
gfc_todo_error ("IOLENGTH statement");
|
||||
}
|
||||
|
||||
static gfc_expr *
|
||||
gfc_new_nml_name_expr (char * name)
|
||||
{
|
||||
@ -858,6 +862,8 @@ build_dt (tree * function, gfc_code * code)
|
||||
set_error_locus (&block, &code->loc);
|
||||
dt = code->ext.dt;
|
||||
|
||||
assert (dt != NULL);
|
||||
|
||||
if (dt->io_unit)
|
||||
{
|
||||
if (dt->io_unit->ts.type == BT_CHARACTER)
|
||||
@ -973,6 +979,41 @@ build_dt (tree * function, gfc_code * code)
|
||||
}
|
||||
|
||||
|
||||
/* Translate the IOLENGTH form of an INQUIRE statement. We treat
|
||||
this as a third sort of data transfer statement, except that
|
||||
lengths are summed instead of actually transfering any data. */
|
||||
|
||||
tree
|
||||
gfc_trans_iolength (gfc_code * code)
|
||||
{
|
||||
stmtblock_t block;
|
||||
gfc_inquire *inq;
|
||||
tree dt;
|
||||
|
||||
gfc_init_block (&block);
|
||||
|
||||
set_error_locus (&block, &code->loc);
|
||||
|
||||
inq = code->ext.inquire;
|
||||
|
||||
/* First check that preconditions are met. */
|
||||
assert(inq != NULL);
|
||||
assert(inq->iolength != NULL);
|
||||
|
||||
/* Connect to the iolength variable. */
|
||||
if (inq->iolength)
|
||||
set_parameter_ref (&block, ioparm_iolength, inq->iolength);
|
||||
|
||||
/* Actual logic. */
|
||||
last_dt = IOLENGTH;
|
||||
dt = build_dt(&iocall_iolength, code);
|
||||
|
||||
gfc_add_expr_to_block (&block, dt);
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
|
||||
/* Translate a READ statement. */
|
||||
|
||||
tree
|
||||
@ -1005,12 +1046,33 @@ gfc_trans_dt_end (gfc_code * code)
|
||||
|
||||
gfc_init_block (&block);
|
||||
|
||||
function = (last_dt == READ) ? iocall_read_done : iocall_write_done;
|
||||
switch (last_dt)
|
||||
{
|
||||
case READ:
|
||||
function = iocall_read_done;
|
||||
break;
|
||||
|
||||
case WRITE:
|
||||
function = iocall_write_done;
|
||||
break;
|
||||
|
||||
case IOLENGTH:
|
||||
function = iocall_iolength_done;
|
||||
break;
|
||||
|
||||
default:
|
||||
abort ();
|
||||
}
|
||||
|
||||
tmp = gfc_build_function_call (function, NULL);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
io_result (&block, code->ext.dt->err, code->ext.dt->end, code->ext.dt->eor);
|
||||
if (last_dt != IOLENGTH)
|
||||
{
|
||||
assert(code->ext.dt != NULL);
|
||||
io_result (&block, code->ext.dt->err,
|
||||
code->ext.dt->end, code->ext.dt->eor);
|
||||
}
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
@ -1087,6 +1149,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
||||
tmp = gfc_build_function_call (function, args);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
gfc_add_block_to_block (&se->pre, &se->post);
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
@ -1,3 +1,8 @@
|
||||
2004-06-22 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* gfortran.fortran-torture/execute/iolength_1.f90: New test.
|
||||
* gfortran.fortran-torture/execute/iolength_3.f90: New test.
|
||||
|
||||
2004-06-21 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* gfortran.fortran-torture/execute/select_1.f90: Rename function
|
||||
|
@ -0,0 +1,16 @@
|
||||
! Test that IOLENGTH works for dynamic arrays
|
||||
program iolength_1
|
||||
implicit none
|
||||
! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
|
||||
integer, parameter :: int32 = selected_int_kind(9)
|
||||
integer(int32), allocatable :: a(:)
|
||||
integer :: iol, alength
|
||||
real :: r
|
||||
call random_number(r)
|
||||
alength = nint(r*20)
|
||||
allocate(a(alength))
|
||||
inquire (iolength = iol) a
|
||||
if ( 4*alength /= iol) then
|
||||
call abort
|
||||
end if
|
||||
end program iolength_1
|
@ -0,0 +1,15 @@
|
||||
! Test that IOLENGTH works for io list containing more than one entry
|
||||
program iolength_3
|
||||
implicit none
|
||||
integer, parameter :: &
|
||||
! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
|
||||
int32 = selected_int_kind(9), &
|
||||
! IEEE double precision, i.e. 8 bytes
|
||||
dp = selected_real_kind(15, 307)
|
||||
integer(int32) :: a, b, iol
|
||||
real(dp) :: c
|
||||
inquire (iolength = iol) a, b, c
|
||||
if ( 16 /= iol) then
|
||||
call abort
|
||||
end if
|
||||
end program iolength_3
|
@ -1,3 +1,12 @@
|
||||
2004-06-22 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
PR fortran/15750
|
||||
* inquire.c (st_inquire): Add comment
|
||||
* io.h (st_parameter): Add iolength.
|
||||
(st_iolength, st_iolength_done): Declare.
|
||||
* transfer.c (iolength_transfer, iolength_transfer_init,
|
||||
st_iolength, st_iolength_done): New functions.
|
||||
|
||||
2004-06-21 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* etime.c (etime_sub): Remove array rank check;
|
||||
|
@ -348,6 +348,8 @@ inquire_via_filename (void)
|
||||
}
|
||||
|
||||
|
||||
/* Library entry point for the INQUIRE statement (non-IOLENGTH
|
||||
form). */
|
||||
|
||||
void
|
||||
st_inquire (void)
|
||||
|
@ -177,6 +177,8 @@ typedef struct
|
||||
int recl_in;
|
||||
int *recl_out;
|
||||
|
||||
int *iolength;
|
||||
|
||||
char *file;
|
||||
int file_len;
|
||||
char *status;
|
||||
@ -642,6 +644,8 @@ void list_formatted_write (bt, void *, int);
|
||||
#define st_open prefix(st_open)
|
||||
#define st_close prefix(st_close)
|
||||
#define st_inquire prefix(st_inquire)
|
||||
#define st_iolength prefix(st_iolength)
|
||||
#define st_iolength_done prefix(st_iolength_done)
|
||||
#define st_rewind prefix(st_rewind)
|
||||
#define st_read prefix(st_read)
|
||||
#define st_read_done prefix(st_read_done)
|
||||
|
@ -1361,6 +1361,57 @@ finalize_transfer (void)
|
||||
}
|
||||
|
||||
|
||||
/* Transfer function for IOLENGTH. It doesn't actually do any
|
||||
data transfer, it just updates the length counter. */
|
||||
|
||||
static void
|
||||
iolength_transfer (bt type, void *dest, int len)
|
||||
{
|
||||
if (ioparm.iolength != NULL)
|
||||
*ioparm.iolength += len;
|
||||
}
|
||||
|
||||
|
||||
/* Initialize the IOLENGTH data transfer. This function is in essence
|
||||
a very much simplified version of data_transfer_init(), because it
|
||||
doesn't have to deal with units at all. */
|
||||
|
||||
static void
|
||||
iolength_transfer_init (void)
|
||||
{
|
||||
|
||||
if (ioparm.iolength != NULL)
|
||||
*ioparm.iolength = 0;
|
||||
|
||||
g.item_count = 0;
|
||||
|
||||
/* Set up the subroutine that will handle the transfers. */
|
||||
|
||||
transfer = iolength_transfer;
|
||||
|
||||
}
|
||||
|
||||
|
||||
/* Library entry point for the IOLENGTH form of the INQUIRE
|
||||
statement. The IOLENGTH form requires no I/O to be performed, but
|
||||
it must still be a runtime library call so that we can determine
|
||||
the iolength for dynamic arrays and such. */
|
||||
|
||||
void
|
||||
st_iolength (void)
|
||||
{
|
||||
library_start ();
|
||||
|
||||
iolength_transfer_init ();
|
||||
}
|
||||
|
||||
void
|
||||
st_iolength_done (void)
|
||||
{
|
||||
library_end ();
|
||||
}
|
||||
|
||||
|
||||
/* The READ statement */
|
||||
|
||||
void
|
||||
|
Loading…
Reference in New Issue
Block a user