projects / gcc.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
PR 78534, 83704 Handle large formatted I/O
[gcc.git] / libgfortran / io / transfer.c
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 298b29e8d3ef2e11ebe49256a42304d59ad2dd8b..f9c8696766f43b62e5f51bf3241f7fa7fccbbaa2 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2017 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 Free Software Foundation, Inc.
    Contributed by Andy Vaught
    Namelist transfer functions contributed by Paul Thomas
    F2003 I/O support contributed by Jerry DeLisle
@@ -93,17 +93,17 @@ export_proto(transfer_logical);
 extern void transfer_logical_write (st_parameter_dt *, void *, int);
 export_proto(transfer_logical_write);
 
-extern void transfer_character (st_parameter_dt *, void *, int);
+extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type);
 export_proto(transfer_character);
 
-extern void transfer_character_write (st_parameter_dt *, void *, int);
+extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type);
 export_proto(transfer_character_write);
 
-extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int);
 export_proto(transfer_character_wide);
 
 extern void transfer_character_wide_write (st_parameter_dt *,
-                                          void *, int, int);
+                                          void *, gfc_charlen_type, int);
 export_proto(transfer_character_wide_write);
 
 extern void transfer_complex (st_parameter_dt *, void *, int);
@@ -223,11 +223,11 @@ current_mode (st_parameter_dt *dtp)
 /* Read sequential file - internal unit  */
 
 static char *
-read_sf_internal (st_parameter_dt *dtp, int *length)
+read_sf_internal (st_parameter_dt *dtp, size_t *length)
 {
   static char *empty_string[0];
   char *base = NULL;
-  int lorig;
+  size_t lorig;
 
   /* Zero size array gives internal unit len of 0.  Nothing to read. */
   if (dtp->internal_unit_len == 0
@@ -256,11 +256,10 @@ read_sf_internal (st_parameter_dt *dtp, int *length)
   lorig = *length;
   if (is_char4_unit(dtp))
     {
-      int i;
       gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
                        length);
       base = fbuf_alloc (dtp->u.p.current_unit, lorig);
-      for (i = 0; i < *length; i++, p++)
+      for (size_t i = 0; i < *length; i++, p++)
        base[i] = *p > 255 ? '?' : (unsigned char) *p;
     }
   else
@@ -297,11 +296,12 @@ read_sf_internal (st_parameter_dt *dtp, int *length)
 /* Read sequential file - external unit */
 
 static char *
-read_sf (st_parameter_dt *dtp, int *length)
+read_sf (st_parameter_dt *dtp, size_t *length)
 {
   static char *empty_string[0];
+  size_t lorig, n;
   int q, q2;
-  int n, lorig, seen_comma;
+  int seen_comma;
 
   /* If we have seen an eor previously, return a length of 0.  The
      caller is responsible for correctly padding the input field.  */
@@ -439,10 +439,10 @@ read_sf (st_parameter_dt *dtp, int *length)
    short reads.  */
 
 void *
-read_block_form (st_parameter_dt *dtp, int *nbytes)
+read_block_form (st_parameter_dt *dtp, size_t *nbytes)
 {
   char *source;
-  int norig;
+  size_t norig;
 
   if (!is_stream_io (dtp))
     {
@@ -451,7 +451,7 @@ read_block_form (st_parameter_dt *dtp, int *nbytes)
          /* For preconnected units with default record length, set bytes left
           to unit record length and proceed, otherwise error.  */
          if (dtp->u.p.current_unit->unit_number == options.stdin_unit
-             && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+             && dtp->u.p.current_unit->recl == default_recl)
             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
          else
            {
@@ -534,11 +534,11 @@ read_block_form (st_parameter_dt *dtp, int *nbytes)
    a character(kind=4) variable.  Note: Portions of this code borrowed from
    read_sf_internal.  */
 void *
-read_block_form4 (st_parameter_dt *dtp, int *nbytes)
+read_block_form4 (st_parameter_dt *dtp, size_t *nbytes)
 {
   static gfc_char4_t *empty_string[0];
   gfc_char4_t *source;
-  int lorig;
+  size_t lorig;
 
   if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
     *nbytes = dtp->u.p.current_unit->bytes_left;
@@ -743,7 +743,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
    fill in.  Returns NULL on error.  */
 
 void *
-write_block (st_parameter_dt *dtp, int length)
+write_block (st_parameter_dt *dtp, size_t length)
 {
   char *dest;
 
@@ -757,7 +757,7 @@ write_block (st_parameter_dt *dtp, int length)
                       == options.stdout_unit
                       || dtp->u.p.current_unit->unit_number
                       == options.stderr_unit)
-                     && dtp->u.p.current_unit->recl == DEFAULT_RECL))
+                     && dtp->u.p.current_unit->recl == default_recl))
            dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
          else
            {
@@ -1792,7 +1792,7 @@ static void
 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
                                 size_t size)
 {
-  int pos, bytes_used;
+  gfc_offset pos, bytes_used;
   const fnode *f;
   format_token t;
   int n;
@@ -1856,10 +1856,10 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
        {
          if (dtp->u.p.skips > 0)
            {
-             int tmp;
+             gfc_offset tmp;
              write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
-             tmp = (int)(dtp->u.p.current_unit->recl
-                         - dtp->u.p.current_unit->bytes_left);
+             tmp = dtp->u.p.current_unit->recl
+                         - dtp->u.p.current_unit->bytes_left;
              dtp->u.p.max_pos =
                dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
              dtp->u.p.skips = 0;
@@ -1875,8 +1875,8 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
          dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
        }
 
-      bytes_used = (int)(dtp->u.p.current_unit->recl
-                  - dtp->u.p.current_unit->bytes_left);
+      bytes_used = dtp->u.p.current_unit->recl
+                  - dtp->u.p.current_unit->bytes_left;
 
       if (is_stream_io(dtp))
        bytes_used = 0;
@@ -2231,7 +2231,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
          p = ((char *) p) + size;
        }
 
-      pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+      pos = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
     }
 
@@ -2331,7 +2331,7 @@ transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
 }
 
 void
-transfer_character (st_parameter_dt *dtp, void *p, int len)
+transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
 {
   static char *empty_string[0];
 
@@ -2349,13 +2349,13 @@ transfer_character (st_parameter_dt *dtp, void *p, int len)
 }
 
 void
-transfer_character_write (st_parameter_dt *dtp, void *p, int len)
+transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
 {
   transfer_character (dtp, p, len);
 }
 
 void
-transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
 {
   static char *empty_string[0];
 
@@ -2373,7 +2373,7 @@ transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
 }
 
 void
-transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
+transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
 {
   transfer_character_wide (dtp, p, len, kind);
 }
@@ -2410,7 +2410,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
     return;
 
   iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
-  size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
+  size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc);
 
   rank = GFC_DESCRIPTOR_RANK (desc);
   for (n = 0; n < rank; n++)
@@ -2671,7 +2671,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 
   dtp->u.p.ionml = ionml;
   dtp->u.p.mode = read_flag ? READING : WRITING;
-
+  dtp->u.p.namelist_mode = 0;
   dtp->u.p.cc.len = 0;
 
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
@@ -2723,8 +2723,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       if (conv == GFC_CONVERT_NONE)
        conv = compile_options.convert;
 
-      /* We use big_endian, which is 0 on little-endian machines
-        and 1 on big-endian machines.  */
       switch (conv)
        {
        case GFC_CONVERT_NATIVE:
@@ -2732,11 +2730,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
          break;
 
        case GFC_CONVERT_BIG:
-         conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+         conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
          break;
 
        case GFC_CONVERT_LITTLE:
-         conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+         conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
          break;
 
        default:
@@ -2766,6 +2764,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       else
        dtp->u.p.current_unit->has_size = false;
     }
+  else if (dtp->u.p.current_unit->internal_unit_kind > 0)
+    dtp->u.p.unit_is_internal = 1;
 
   /* Check the action.  */
 
@@ -3290,7 +3290,7 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
    position.  */
 
 static void
-skip_record (st_parameter_dt *dtp, ssize_t bytes)
+skip_record (st_parameter_dt *dtp, gfc_offset bytes)
 {
   ssize_t rlength, readb;
 #define MAX_READ 4096
@@ -3367,7 +3367,6 @@ static void
 next_record_r (st_parameter_dt *dtp, int done)
 {
   gfc_offset record;
-  int bytes_left;
   char p;
   int cc;
 
@@ -3419,7 +3418,7 @@ next_record_r (st_parameter_dt *dtp, int done)
            }
          else
            {
-             bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+             gfc_offset bytes_left = dtp->u.p.current_unit->bytes_left;
              bytes_left = min_off (bytes_left,
                      ssize (dtp->u.p.current_unit->s)
                      - stell (dtp->u.p.current_unit->s));
@@ -3590,12 +3589,13 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
 /* Utility function like memset() but operating on streams. Return
    value is same as for POSIX write().  */
 
-static ssize_t
-sset (stream *s, int c, ssize_t nbyte)
+static gfc_offset
+sset (stream *s, int c, gfc_offset nbyte)
 {
 #define WRITE_CHUNK 256
   char p[WRITE_CHUNK];
-  ssize_t bytes_left, trans;
+  gfc_offset bytes_left;
+  ssize_t trans;
 
   if (nbyte < WRITE_CHUNK)
     memset (p, c, nbyte);
@@ -3645,11 +3645,10 @@ next_record_cc (st_parameter_dt *dtp)
 static void
 next_record_w (st_parameter_dt *dtp, int done)
 {
-  gfc_offset m, record, max_pos;
-  int length;
+  gfc_offset max_pos_off;
 
   /* Zero counters for X- and T-editing.  */
-  max_pos = dtp->u.p.max_pos;
+  max_pos_off = dtp->u.p.max_pos;
   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 
   switch (current_mode (dtp))
@@ -3674,7 +3673,7 @@ next_record_w (st_parameter_dt *dtp, int done)
     case UNFORMATTED_DIRECT:
       if (dtp->u.p.current_unit->bytes_left > 0)
        {
-         length = (int) dtp->u.p.current_unit->bytes_left;
+         gfc_offset length = dtp->u.p.current_unit->bytes_left;
          if (sset (dtp->u.p.current_unit->s, 0, length) != length)
            goto io_error;
        }
@@ -3691,11 +3690,14 @@ next_record_w (st_parameter_dt *dtp, int done)
       if (is_internal_unit (dtp))
        {
          char *p;
+         /* Internal unit, so must fit in memory.  */
+         size_t length, m, record;
+         size_t max_pos = max_pos_off;
          if (is_array_io (dtp))
            {
              int finished;
 
-             length = (int) dtp->u.p.current_unit->bytes_left;
+             length = dtp->u.p.current_unit->bytes_left;
 
              /* If the farthest position reached is greater than current
              position, adjust the position and set length to pad out
@@ -3705,14 +3707,14 @@ next_record_w (st_parameter_dt *dtp, int done)
                        - dtp->u.p.current_unit->bytes_left;
              if (max_pos > m)
                {
-                 length = (int) (max_pos - m);
+                 length = (max_pos - m);
                  if (sseek (dtp->u.p.current_unit->s,
                             length, SEEK_CUR) < 0)
                    {
                      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
                      return;
                    }
-                 length = (int) (dtp->u.p.current_unit->recl - max_pos);
+                 length = ((size_t) dtp->u.p.current_unit->recl - max_pos);
                }
 
              p = write_block (dtp, length);
@@ -3735,7 +3737,7 @@ next_record_w (st_parameter_dt *dtp, int done)
                dtp->u.p.current_unit->endfile = AT_ENDFILE;
 
              /* Now seek to this record */
-             record = record * dtp->u.p.current_unit->recl;
+             record = record * ((size_t) dtp->u.p.current_unit->recl);
 
              if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
                {
@@ -3758,17 +3760,18 @@ next_record_w (st_parameter_dt *dtp, int done)
                        - dtp->u.p.current_unit->bytes_left;
                  if (max_pos > m)
                    {
-                     length = (int) (max_pos - m);
+                     length = max_pos - m;
                      if (sseek (dtp->u.p.current_unit->s,
                                 length, SEEK_CUR) < 0)
                        {
                          generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
                          return;
                        }
-                     length = (int) (dtp->u.p.current_unit->recl - max_pos);
+                     length = (size_t) dtp->u.p.current_unit->recl
+                       - max_pos;
                    }
                  else
-                   length = (int) dtp->u.p.current_unit->bytes_left;
+                   length = dtp->u.p.current_unit->bytes_left;
                }
              if (length > 0)
                {
@@ -3887,6 +3890,7 @@ finalize_transfer (st_parameter_dt *dtp)
   if ((dtp->u.p.ionml != NULL)
       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
     {
+       dtp->u.p.namelist_mode = 1;
        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
         namelist_read (dtp);
        else
@@ -3981,6 +3985,19 @@ finalize_transfer (st_parameter_dt *dtp)
   next_record (dtp, 1);
 
  done:
+
+  if (dtp->u.p.unit_is_internal)
+    {
+      fbuf_destroy (dtp->u.p.current_unit);
+      if (dtp->u.p.current_unit
+         && (dtp->u.p.current_unit->child_dtio  == 0)
+         && dtp->u.p.current_unit->s)
+       {
+         sclose (dtp->u.p.current_unit->s);
+         dtp->u.p.current_unit->s = NULL;
+       }
+    }
+
 #ifdef HAVE_USELOCALE
   if (dtp->u.p.old_locale != (locale_t) 0)
     {
@@ -4080,24 +4097,23 @@ st_read_done (st_parameter_dt *dtp)
   free_ionml (dtp);
 
   /* If this is a parent READ statement we do not need to retain the
-     internal unit structure for child use.  Free it and stash the unit
-     number for reuse.  */
+     internal unit structure for child use.  */
   if (dtp->u.p.current_unit != NULL
       && dtp->u.p.current_unit->child_dtio == 0)
     {
-      if (is_internal_unit (dtp) &&
-         (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
-        {
-         free (dtp->u.p.current_unit->filename);
-         dtp->u.p.current_unit->filename = NULL;
-         free (dtp->u.p.current_unit->s);
-         dtp->u.p.current_unit->s = NULL;
-         if (dtp->u.p.current_unit->ls)
-           free (dtp->u.p.current_unit->ls);
-         dtp->u.p.current_unit->ls = NULL;
-         stash_internal_unit (dtp);
+      if (dtp->u.p.unit_is_internal)
+       {
+         if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+           {
+             free (dtp->u.p.current_unit->filename);
+             dtp->u.p.current_unit->filename = NULL;
+             if (dtp->u.p.current_unit->ls)
+               free (dtp->u.p.current_unit->ls);
+             dtp->u.p.current_unit->ls = NULL;
+           }
+         newunit_free (dtp->common.unit);
        }
-      if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+      if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
        {
          free_format_data (dtp->u.p.fmt);
          free_format (dtp);
@@ -4153,21 +4169,20 @@ st_write_done (st_parameter_dt *dtp)
       free_ionml (dtp);
 
       /* If this is a parent WRITE statement we do not need to retain the
-        internal unit structure for child use.  Free it and stash the
-        unit number for reuse.  */
-      if (is_internal_unit (dtp) &&
-         (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+        internal unit structure for child use.  */
+      if (dtp->u.p.unit_is_internal)
        {
-         free (dtp->u.p.current_unit->filename);
-         dtp->u.p.current_unit->filename = NULL;
-         free (dtp->u.p.current_unit->s);
-         dtp->u.p.current_unit->s = NULL;
-         if (dtp->u.p.current_unit->ls)
-           free (dtp->u.p.current_unit->ls);
-         dtp->u.p.current_unit->ls = NULL;
-         stash_internal_unit (dtp);
+         if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+           {
+             free (dtp->u.p.current_unit->filename);
+             dtp->u.p.current_unit->filename = NULL;
+             if (dtp->u.p.current_unit->ls)
+               free (dtp->u.p.current_unit->ls);
+             dtp->u.p.current_unit->ls = NULL;
+           }
+         newunit_free (dtp->common.unit);
        }
-      if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+      if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
        {
          free_format_data (dtp->u.p.fmt);
          free_format (dtp);