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

@@ -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

gcc/fortran/io.c

@@ -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;
 }

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;
 

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);
+
 }
 
 

gcc/testsuite/ChangeLog

@@ -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

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

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

libgfortran/ChangeLog

@@ -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;

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)

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)

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