From 8750f9cdec153095cc47c41b887bc86fda4a0e3e Mon Sep 17 00:00:00 2001 From: Janne Blomqvist Date: Tue, 22 Jun 2004 03:43:55 +0300 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 14 +++ gcc/fortran/io.c | 5 +- gcc/fortran/resolve.c | 9 +- gcc/fortran/trans-io.c | 89 ++++++++++++++++--- gcc/testsuite/ChangeLog | 5 ++ .../execute/iolength_1.f90 | 16 ++++ .../execute/iolength_3.f90 | 15 ++++ libgfortran/ChangeLog | 9 ++ libgfortran/io/inquire.c | 2 + libgfortran/io/io.h | 4 + libgfortran/io/transfer.c | 51 +++++++++++ 11 files changed, 203 insertions(+), 16 deletions(-) create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 41c9a90a780..01147289fb4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2004-06-22 Janne Blomqvist + + 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 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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 77ac3d4bb8d..03851f5ad5e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index c0570fc8575..3f4076fc557 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -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); + } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fbfcf4464f3..73cebd14a47 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-06-22 Janne Blomqvist + + * gfortran.fortran-torture/execute/iolength_1.f90: New test. + * gfortran.fortran-torture/execute/iolength_3.f90: New test. + 2004-06-21 Tobias Schlueter * gfortran.fortran-torture/execute/select_1.f90: Rename function diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 new file mode 100644 index 00000000000..8b22b03a7ce --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 new file mode 100644 index 00000000000..23f14c63660 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 107f9035356..933187a9c82 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2004-06-22 Janne Blomqvist + + 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 * etime.c (etime_sub): Remove array rank check; diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index 20bea1f887d..36957dde58f 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -348,6 +348,8 @@ inquire_via_filename (void) } +/* Library entry point for the INQUIRE statement (non-IOLENGTH + form). */ void st_inquire (void) diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 7658ec8f605..8ad25993ce4 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -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) diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 04b7c5a7ac2..b20f860bcef 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -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 -- 2.30.2