2010-06-18 Jerry DeLisle <jvdelisle@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / libgfortran / io / transfer.c

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 7d833b7..9f2aafa 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010

    Free Software Foundation, Inc.
    Contributed by Andy Vaught
    Namelist transfer functions contributed by Paul Thomas
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
    Namelist transfer functions contributed by Paul Thomas


@@ -29,6 +29,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 /* transfer.c -- Top level handling of data transfer statements.  */
 
 #include "io.h"
 /* transfer.c -- Top level handling of data transfer statements.  */
 
 #include "io.h"

+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"

 #include <string.h>
 #include <assert.h>
 #include <stdlib.h>
 #include <string.h>
 #include <assert.h>
 #include <stdlib.h>


@@ -101,6 +104,16 @@ static const st_option decimal_opt[] = {
   {NULL, 0}
 };
 
   {NULL, 0}
 };
 

+static const st_option round_opt[] = {
+  {"up", ROUND_UP},
+  {"down", ROUND_DOWN},
+  {"zero", ROUND_ZERO},
+  {"nearest", ROUND_NEAREST},
+  {"compatible", ROUND_COMPATIBLE},
+  {"processor_defined", ROUND_PROCDEFINED},
+  {NULL, 0}
+};
+

 
 static const st_option sign_opt[] = {
   {"plus", SIGN_SP},
 
 static const st_option sign_opt[] = {
   {"plus", SIGN_SP},


@@ -162,9 +175,7 @@ current_mode (st_parameter_dt *dtp)
 }
 
 
 }
 
 

-/* Mid level data transfer statements.  These subroutines do reading
-   and writing in the style of salloc_r()/salloc_w() within the
-   current record.  */
+/* Mid level data transfer statements.  */

 
 /* When reading sequential formatted records we have a problem.  We
    don't know how long the line is until we read the trailing newline,
 
 /* When reading sequential formatted records we have a problem.  We
    don't know how long the line is until we read the trailing newline,


@@ -177,24 +188,57 @@ current_mode (st_parameter_dt *dtp)
    we hit the newline.  For small allocations, we use a static buffer.
    For larger allocations, we are forced to allocate memory on the
    heap.  Hopefully this won't happen very often.  */
    we hit the newline.  For small allocations, we use a static buffer.
    For larger allocations, we are forced to allocate memory on the
    heap.  Hopefully this won't happen very often.  */

+   
+/* Read sequential file - internal unit  */

 
 

-char *
-read_sf (st_parameter_dt *dtp, int * length, int no_error)
+static char *
+read_sf_internal (st_parameter_dt *dtp, int * length)

 {
   static char *empty_string[0];
 {
   static char *empty_string[0];

-  char *base, *p, q;
-  int n, lorig, memread, seen_comma;
+  char *base;
+  int lorig;
+
+  /* Zero size array gives internal unit len of 0.  Nothing to read. */
+  if (dtp->internal_unit_len == 0
+      && dtp->u.p.current_unit->pad_status == PAD_NO)
+    hit_eof (dtp);

 
 

-  /* If we hit EOF previously with the no_error flag set (i.e. X, T,
-     TR edit descriptors), and we now try to read again, this time
-     without setting no_error.  */
-  if (!no_error && dtp->u.p.at_eof)
+  /* If we have seen an eor previously, return a length of 0.  The
+     caller is responsible for correctly padding the input field.  */
+  if (dtp->u.p.sf_seen_eor)

     {
       *length = 0;
     {
       *length = 0;

+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return (char*) empty_string;
+    }
+
+  lorig = *length;
+  base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+  if (unlikely (lorig > *length))
+    {

       hit_eof (dtp);
       return NULL;
     }
 
       hit_eof (dtp);
       return NULL;
     }
 

+  dtp->u.p.current_unit->bytes_left -= *length;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) *length;
+
+  return base;
+
+}
+
+/* Read sequential file - external unit */
+
+static char *
+read_sf (st_parameter_dt *dtp, int * length)
+{
+  static char *empty_string[0];
+  char *base, *p, q;
+  int n, lorig, seen_comma;
+

   /* If we have seen an eor previously, return a length of 0.  The
      caller is responsible for correctly padding the input field.  */
   if (dtp->u.p.sf_seen_eor)
   /* If we have seen an eor previously, return a length of 0.  The
      caller is responsible for correctly padding the input field.  */
   if (dtp->u.p.sf_seen_eor)


@@ -205,19 +249,6 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
       return (char*) empty_string;
     }
 
       return (char*) empty_string;
     }
 

-  if (is_internal_unit (dtp))
-    {
-      memread = *length;
-      base = mem_alloc_r (dtp->u.p.current_unit->s, length);
-      if (unlikely (memread > *length))
-       {
-          hit_eof (dtp);
-         return NULL;
-       }
-      n = *length;
-      goto done;
-    }
-

   n = seen_comma = 0;
 
   /* Read data into format buffer and scan through it.  */
   n = seen_comma = 0;
 
   /* Read data into format buffer and scan through it.  */


@@ -232,35 +263,40 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
 
       if (q == '\n' || q == '\r')
        {
 
       if (q == '\n' || q == '\r')
        {

-         /* Unexpected end of line.  */
+         /* Unexpected end of line. Set the position.  */
+         fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
+         dtp->u.p.sf_seen_eor = 1;

 
          /* If we see an EOR during non-advancing I/O, we need to skip
             the rest of the I/O statement.  Set the corresponding flag.  */
          if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
            dtp->u.p.eor_condition = 1;
 
          /* If we see an EOR during non-advancing I/O, we need to skip
             the rest of the I/O statement.  Set the corresponding flag.  */
          if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
            dtp->u.p.eor_condition = 1;

-
+           

          /* If we encounter a CR, it might be a CRLF.  */
          if (q == '\r') /* Probably a CRLF */
            {
          /* If we encounter a CR, it might be a CRLF.  */
          if (q == '\r') /* Probably a CRLF */
            {

-             if (n < *length && *(p + 1) == '\n')
-               dtp->u.p.sf_seen_eor = 2;
+             /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
+                the position is not advanced unless it really is an LF.  */
+             int readlen = 1;
+             p = fbuf_read (dtp->u.p.current_unit, &readlen);
+             if (*p == '\n' && readlen == 1)
+               {
+                 dtp->u.p.sf_seen_eor = 2;
+                 fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
+               }

            }
            }

-          else
-            dtp->u.p.sf_seen_eor = 1;

 
          /* Without padding, terminate the I/O statement without assigning
             the value.  With padding, the value still needs to be assigned,
             so we can just continue with a short read.  */
          if (dtp->u.p.current_unit->pad_status == PAD_NO)
            {
 
          /* Without padding, terminate the I/O statement without assigning
             the value.  With padding, the value still needs to be assigned,
             so we can just continue with a short read.  */
          if (dtp->u.p.current_unit->pad_status == PAD_NO)
            {

-             if (likely (no_error))
-               break;

              generate_error (&dtp->common, LIBERROR_EOR, NULL);
              return NULL;
            }
 
          *length = n;
              generate_error (&dtp->common, LIBERROR_EOR, NULL);
              return NULL;
            }
 
          *length = n;

-         break;
+         goto done;

        }
       /*  Short circuit the read if a comma is found during numeric input.
          The flag is set to zero during character reads so that commas in
        }
       /*  Short circuit the read if a comma is found during numeric input.
          The flag is set to zero during character reads so that commas in


@@ -274,25 +310,39 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
            *length = n;
            break;
          }
            *length = n;
            break;
          }

-

       n++;
       p++;
     } 
 
       n++;
       p++;
     } 
 

-  fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + seen_comma, 
-             SEEK_CUR);
+  fbuf_seek (dtp->u.p.current_unit, n + seen_comma, SEEK_CUR);

 
   /* A short read implies we hit EOF, unless we hit EOR, a comma, or
      some other stuff. Set the relevant flags.  */
   if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
     {
 
   /* A short read implies we hit EOF, unless we hit EOR, a comma, or
      some other stuff. Set the relevant flags.  */
   if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
     {

-      if (no_error)
-        dtp->u.p.at_eof = 1;
-      else
+      if (n > 0)

         {
         {

-          hit_eof (dtp);
-          return NULL;
-        }
+         if (dtp->u.p.advance_status == ADVANCE_NO)
+           {
+             if (dtp->u.p.current_unit->pad_status == PAD_NO)
+               {
+                 hit_eof (dtp);
+                 return NULL;
+               }
+             else
+               dtp->u.p.eor_condition = 1;
+           }
+         else
+           dtp->u.p.at_eof = 1;
+       }
+      else if (dtp->u.p.advance_status == ADVANCE_NO
+              || dtp->u.p.current_unit->pad_status == PAD_NO
+              || dtp->u.p.current_unit->bytes_left
+                   == dtp->u.p.current_unit->recl)
+       {
+         hit_eof (dtp);
+         return NULL;
+       }

     }
 
  done:
     }
 
  done:


@@ -333,7 +383,8 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
          else
            {
             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
          else
            {

-             if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO))
+             if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
+                 && !is_internal_unit (dtp))

                {
                  /* Not enough data left.  */
                  generate_error (&dtp->common, LIBERROR_EOR, NULL);
                {
                  /* Not enough data left.  */
                  generate_error (&dtp->common, LIBERROR_EOR, NULL);


@@ -341,9 +392,10 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
                }
            }
 
                }
            }
 

-         if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
+         if (unlikely (dtp->u.p.current_unit->bytes_left == 0
+             && !is_internal_unit(dtp)))

            {
            {

-              hit_eof (dtp);
+             hit_eof (dtp);

              return NULL;
            }
 
              return NULL;
            }
 


@@ -355,7 +407,11 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
       (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
        dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
     {
       (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
        dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
     {

-      source = read_sf (dtp, nbytes, 0);
+      if (is_internal_unit (dtp))
+       source = read_sf_internal (dtp, nbytes);
+      else
+       source = read_sf (dtp, nbytes);
+

       dtp->u.p.current_unit->strm_pos +=
        (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
       return source;
       dtp->u.p.current_unit->strm_pos +=
        (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
       return source;


@@ -894,8 +950,9 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
   if (actual == expected)
     return 0;
 
   if (actual == expected)
     return 0;
 

+  /* Adjust item_count before emitting error message.  */

   sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
   sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",

-          type_name (expected), dtp->u.p.item_count, type_name (actual));
+          type_name (expected), dtp->u.p.item_count - 1, type_name (actual));

 
   format_error (dtp, f, buffer);
   return 1;
 
   format_error (dtp, f, buffer);
   return 1;


@@ -1197,6 +1254,36 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
          consume_data_flag = 0;
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;
          consume_data_flag = 0;
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;

+       
+       case FMT_RC:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+         break;
+
+       case FMT_RD:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_DOWN;
+         break;
+
+       case FMT_RN:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+         break;
+
+       case FMT_RP:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+         break;
+
+       case FMT_RU:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_UP;
+         break;
+
+       case FMT_RZ:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_ZERO;
+         break;

 
        case FMT_P:
          consume_data_flag = 0;
 
        case FMT_P:
          consume_data_flag = 0;


@@ -1561,6 +1648,36 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;
 
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;
 

+       case FMT_RC:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+         break;
+
+       case FMT_RD:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_DOWN;
+         break;
+
+       case FMT_RN:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+         break;
+
+       case FMT_RP:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+         break;
+
+       case FMT_RU:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_UP;
+         break;
+
+       case FMT_RZ:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_ZERO;
+         break;
+

        case FMT_P:
          consume_data_flag = 0;
          dtp->u.p.scale_factor = f->u.k;
        case FMT_P:
          consume_data_flag = 0;
          dtp->u.p.scale_factor = f->u.k;


@@ -1612,6 +1729,12 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
   unget_format (dtp, f);
 }
 
   unget_format (dtp, f);
 }
 

+  /* This function is first called from data_init_transfer to initiate the loop
+     over each item in the format, transferring data as required.  Subsequent
+     calls to this function occur for each data item foound in the READ/WRITE
+     statement.  The item_count is incremented for each call.  Since the first
+     call is from data_transfer_init, the item_count is always one greater than
+     the actual count number of the item being transferred.  */

 
 static void
 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
 
 static void
 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,


@@ -2144,15 +2267,25 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       return;
     }
 
       return;
     }
 

-  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
-      && (cf & IOPARM_DT_HAS_REC) != 0)
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)

     {
     {

-      generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-                     "Record number not allowed for sequential access "
-                     "data transfer");
-      return;
-    }
+      if ((cf & IOPARM_DT_HAS_REC) != 0)
+       {
+         generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+                       "Record number not allowed for sequential access "
+                       "data transfer");
+         return;
+       }
+
+      if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
+       {
+         generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+                       "Sequential READ or WRITE not allowed after "
+                       "EOF marker, possibly use REWIND or BACKSPACE");
+         return;
+       }

 
 

+    }

   /* Process the ADVANCE option.  */
 
   dtp->u.p.advance_status
   /* Process the ADVANCE option.  */
 
   dtp->u.p.advance_status


@@ -2247,6 +2380,16 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
        dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
 
   if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
        dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
 

+  /* Check the round mode.  */
+  dtp->u.p.current_unit->round_status
+       = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
+         find_option (&dtp->common, dtp->round, dtp->round_len,
+                       round_opt, "Bad ROUND parameter in data transfer "
+                       "statement");
+
+  if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
+       dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
+

   /* Check the sign mode. */
   dtp->u.p.sign_status
        = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
   /* Check the sign mode. */
   dtp->u.p.sign_status
        = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :


@@ -2573,6 +2716,8 @@ skip_record (st_parameter_dt *dtp, ssize_t bytes)
       if (sseek (dtp->u.p.current_unit->s, 
                 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
        generate_error (&dtp->common, LIBERROR_OS, NULL);
       if (sseek (dtp->u.p.current_unit->s, 
                 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
        generate_error (&dtp->common, LIBERROR_OS, NULL);

+
+      dtp->u.p.current_unit->bytes_left_subrecord = 0;

     }
   else
     {                  /* Seek by reading data.  */
     }
   else
     {                  /* Seek by reading data.  */


@@ -2633,7 +2778,7 @@ min_off (gfc_offset a, gfc_offset b)
 /* Space to the next record for read mode.  */
 
 static void
 /* Space to the next record for read mode.  */
 
 static void

-next_record_r (st_parameter_dt *dtp)
+next_record_r (st_parameter_dt *dtp, int done)

 {
   gfc_offset record;
   int bytes_left;
 {
   gfc_offset record;
   int bytes_left;


@@ -2653,17 +2798,16 @@ next_record_r (st_parameter_dt *dtp)
 
     case FORMATTED_DIRECT:
     case UNFORMATTED_DIRECT:
 
     case FORMATTED_DIRECT:
     case UNFORMATTED_DIRECT:

-      skip_record (dtp, 0);
+      skip_record (dtp, dtp->u.p.current_unit->bytes_left);

       break;
 
     case FORMATTED_STREAM:
     case FORMATTED_SEQUENTIAL:
       /* read_sf has already terminated input because of an '\n', or
          we have hit EOF.  */
       break;
 
     case FORMATTED_STREAM:
     case FORMATTED_SEQUENTIAL:
       /* read_sf has already terminated input because of an '\n', or
          we have hit EOF.  */

-      if (dtp->u.p.sf_seen_eor || dtp->u.p.at_eof)
+      if (dtp->u.p.sf_seen_eor)

        {
          dtp->u.p.sf_seen_eor = 0;
        {
          dtp->u.p.sf_seen_eor = 0;

-          dtp->u.p.at_eof = 0;

          break;
        }
 
          break;
        }
 


@@ -2675,6 +2819,8 @@ next_record_r (st_parameter_dt *dtp)
 
              record = next_array_record (dtp, dtp->u.p.current_unit->ls,
                                          &finished);
 
              record = next_array_record (dtp, dtp->u.p.current_unit->ls,
                                          &finished);

+             if (!done && finished)
+               hit_eof (dtp);

 
              /* Now seek to this record.  */
              record = record * dtp->u.p.current_unit->recl;
 
              /* Now seek to this record.  */
              record = record * dtp->u.p.current_unit->recl;


@@ -2712,8 +2858,14 @@ next_record_r (st_parameter_dt *dtp)
                {
                   if (errno != 0)
                     generate_error (&dtp->common, LIBERROR_OS, NULL);
                {
                   if (errno != 0)
                     generate_error (&dtp->common, LIBERROR_OS, NULL);

-                  else
-                    hit_eof (dtp);
+                 else
+                   {
+                     if (is_stream_io (dtp)
+                         || dtp->u.p.current_unit->pad_status == PAD_NO
+                         || dtp->u.p.current_unit->bytes_left
+                            == dtp->u.p.current_unit->recl)
+                       hit_eof (dtp);
+                   }

                  break;
                 }
              
                  break;
                 }
              


@@ -3053,7 +3205,7 @@ next_record (st_parameter_dt *dtp, int done)
   dtp->u.p.current_unit->read_bad = 0;
 
   if (dtp->u.p.mode == READING)
   dtp->u.p.current_unit->read_bad = 0;
 
   if (dtp->u.p.mode == READING)

-    next_record_r (dtp);
+    next_record_r (dtp, done);

   else
     next_record_w (dtp, done);
 
   else
     next_record_w (dtp, done);
 


@@ -3103,7 +3255,11 @@ finalize_transfer (st_parameter_dt *dtp)
     }
 
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     }
 
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)

-    return;
+    {
+      if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
+       dtp->u.p.current_unit->current_record = 0;
+      return;
+    }

 
   if ((dtp->u.p.ionml != NULL)
       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
 
   if ((dtp->u.p.ionml != NULL)
       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)