libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught and Janne Blomqvist
   3
   4 This file is part of the GNU Fortran runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 3, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 Under Section 7 of GPL version 3, you are granted additional
  17 permissions described in the GCC Runtime Library Exception, version
  18 3.1, as published by the Free Software Foundation.
  19
  20 You should have received a copy of the GNU General Public License and
  21 a copy of the GCC Runtime Library Exception along with this program;
  22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  23 <http://www.gnu.org/licenses/>.  */
  24
  25 #include "io.h"
  26 #include <string.h>
  27
  28 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  29    ENDFILE, and REWIND as well as the FLUSH statement.  */
  30
  31
  32 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  33    current position is after the newline that terminates the previous
  34    record, and we have to sift backwards to find the newline before
  35    that or the start of the file, whichever comes first.  */
  36
  37 static const int READ_CHUNK = 4096;
  38
  39 static void
  40 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  41 {
  42   gfc_offset base;
  43   char p[READ_CHUNK];
  44   ssize_t n;
  45
  46   base = stell (u->s) - 1;
  47
  48   do
  49     {
  50       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  51       base -= n;
  52       if (sseek (u->s, base, SEEK_SET) < 0)
  53         goto io_error;
  54       if (sread (u->s, p, n) != n)
  55         goto io_error;
  56
  57       /* We have moved backwards from the current position, it should
  58          not be possible to get a short read.  Because it is not
  59          clear what to do about such thing, we ignore the possibility.  */
  60
  61       /* There is no memrchr() in the C library, so we have to do it
  62          ourselves.  */
  63
  64       while (n > 0)
  65         {
  66           n--;
  67           if (p[n] == '\n')
  68             {
  69               base += n + 1;
  70               goto done;
  71             }
  72         }
  73
  74     }
  75   while (base != 0);
  76
  77   /* base is the new pointer.  Seek to it exactly.  */
  78  done:
  79   if (sseek (u->s, base, SEEK_SET) < 0)
  80     goto io_error;
  81   u->last_record--;
  82   u->endfile = NO_ENDFILE;
  83
  84   return;
  85
  86  io_error:
  87   generate_error (&fpp->common, LIBERROR_OS, NULL);
  88 }
  89
  90
  91 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
  92    sequential file.  We are guaranteed to be between records on entry and
  93    we have to shift to the previous record.  Loop over subrecords.  */
  94
  95 static void
  96 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  97 {
  98   gfc_offset m, slen;
  99   GFC_INTEGER_4 m4;
 100   GFC_INTEGER_8 m8;
 101   ssize_t length;
 102   int continued;
 103   char p[sizeof (GFC_INTEGER_8)];
 104
 105   if (compile_options.record_marker == 0)
 106     length = sizeof (GFC_INTEGER_4);
 107   else
 108     length = compile_options.record_marker;
 109
 110   do
 111     {
 112       slen = - (gfc_offset) length;
 113       if (sseek (u->s, slen, SEEK_CUR) < 0)
 114         goto io_error;
 115       if (sread (u->s, p, length) != length)
 116         goto io_error;
 117
 118       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
 119       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
 120         {
 121           switch (length)
 122             {
 123             case sizeof(GFC_INTEGER_4):
 124               memcpy (&m4, p, sizeof (m4));
 125               m = m4;
 126               break;
 127
 128             case sizeof(GFC_INTEGER_8):
 129               memcpy (&m8, p, sizeof (m8));
 130               m = m8;
 131               break;
 132
 133             default:
 134               runtime_error ("Illegal value for record marker");
 135               break;
 136             }
 137         }
 138       else
 139         {
 140           switch (length)
 141             {
 142             case sizeof(GFC_INTEGER_4):
 143               reverse_memcpy (&m4, p, sizeof (m4));
 144               m = m4;
 145               break;
 146
 147             case sizeof(GFC_INTEGER_8):
 148               reverse_memcpy (&m8, p, sizeof (m8));
 149               m = m8;
 150               break;
 151
 152             default:
 153               runtime_error ("Illegal value for record marker");
 154               break;
 155             }
 156
 157         }
 158
 159       continued = m < 0;
 160       if (continued)
 161         m = -m;
 162
 163       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 164         goto io_error;
 165     } while (continued);
 166
 167   u->last_record--;
 168   return;
 169
 170  io_error:
 171   generate_error (&fpp->common, LIBERROR_OS, NULL);
 172 }
 173
 174
 175 extern void st_backspace (st_parameter_filepos *);
 176 export_proto(st_backspace);
 177
 178 void
 179 st_backspace (st_parameter_filepos *fpp)
 180 {
 181   gfc_unit *u;
 182
 183   library_start (&fpp->common);
 184
 185   u = find_unit (fpp->common.unit);
 186   if (u == NULL)
 187     {
 188       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 189       goto done;
 190     }
 191
 192   /* Direct access is prohibited, and so is unformatted stream access.  */
 193
 194
 195   if (u->flags.access == ACCESS_DIRECT)
 196     {
 197       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 198                       "Cannot BACKSPACE a file opened for DIRECT access");
 199       goto done;
 200     }
 201
 202   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 203     {
 204       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 205                       "Cannot BACKSPACE an unformatted stream file");
 206       goto done;
 207     }
 208
 209   /* Make sure format buffer is flushed and reset.  */
 210   if (u->flags.form == FORM_FORMATTED)
 211     {
 212       int pos = fbuf_reset (u);
 213       if (pos != 0)
 214         sseek (u->s, pos, SEEK_CUR);
 215     }
 216
 217
 218   /* Check for special cases involving the ENDFILE record first.  */
 219
 220   if (u->endfile == AFTER_ENDFILE)
 221     {
 222       u->endfile = AT_ENDFILE;
 223       u->flags.position = POSITION_APPEND;
 224       sflush (u->s);
 225     }
 226   else
 227     {
 228       if (stell (u->s) == 0)
 229         {
 230           u->flags.position = POSITION_REWIND;
 231           goto done;            /* Common special case */
 232         }
 233
 234       if (u->mode == WRITING)
 235         {
 236           /* If there are previously written bytes from a write with
 237              ADVANCE="no", add a record marker before performing the
 238              BACKSPACE.  */
 239
 240           if (u->previous_nonadvancing_write)
 241             finish_last_advance_record (u);
 242
 243           u->previous_nonadvancing_write = 0;
 244
 245           unit_truncate (u, stell (u->s), &fpp->common);
 246           u->mode = READING;
 247         }
 248
 249       if (u->flags.form == FORM_FORMATTED)
 250         formatted_backspace (fpp, u);
 251       else
 252         unformatted_backspace (fpp, u);
 253
 254       u->flags.position = POSITION_UNSPECIFIED;
 255       u->endfile = NO_ENDFILE;
 256       u->current_record = 0;
 257       u->bytes_left = 0;
 258     }
 259
 260  done:
 261   if (u != NULL)
 262     unlock_unit (u);
 263
 264   library_end ();
 265 }
 266
 267
 268 extern void st_endfile (st_parameter_filepos *);
 269 export_proto(st_endfile);
 270
 271 void
 272 st_endfile (st_parameter_filepos *fpp)
 273 {
 274   gfc_unit *u;
 275
 276   library_start (&fpp->common);
 277
 278   u = find_unit (fpp->common.unit);
 279   if (u != NULL)
 280     {
 281       if (u->flags.access == ACCESS_DIRECT)
 282         {
 283           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 284                           "Cannot perform ENDFILE on a file opened"
 285                           " for DIRECT access");
 286           goto done;
 287         }
 288
 289       /* If there are previously written bytes from a write with ADVANCE="no",
 290          add a record marker before performing the ENDFILE.  */
 291
 292       if (u->previous_nonadvancing_write)
 293         finish_last_advance_record (u);
 294
 295       u->previous_nonadvancing_write = 0;
 296
 297       if (u->current_record)
 298         {
 299           st_parameter_dt dtp;
 300           dtp.common = fpp->common;
 301           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 302           dtp.u.p.current_unit = u;
 303           next_record (&dtp, 1);
 304         }
 305
 306       unit_truncate (u, stell (u->s), &fpp->common);
 307       u->endfile = AFTER_ENDFILE;
 308       if (0 == stell (u->s))
 309         u->flags.position = POSITION_REWIND;
 310     done:
 311       unlock_unit (u);
 312     }
 313
 314   library_end ();
 315 }
 316
 317
 318 extern void st_rewind (st_parameter_filepos *);
 319 export_proto(st_rewind);
 320
 321 void
 322 st_rewind (st_parameter_filepos *fpp)
 323 {
 324   gfc_unit *u;
 325
 326   library_start (&fpp->common);
 327
 328   u = find_unit (fpp->common.unit);
 329   if (u != NULL)
 330     {
 331       if (u->flags.access == ACCESS_DIRECT)
 332         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 333                         "Cannot REWIND a file opened for DIRECT access");
 334       else
 335         {
 336           /* If there are previously written bytes from a write with ADVANCE="no",
 337              add a record marker before performing the ENDFILE.  */
 338
 339           if (u->previous_nonadvancing_write)
 340             finish_last_advance_record (u);
 341
 342           u->previous_nonadvancing_write = 0;
 343
 344           /* Flush the buffers.  If we have been writing to the file, the last
 345                written record is the last record in the file, so truncate the
 346                file now.  Reset to read mode so two consecutive rewind
 347                statements do not delete the file contents.  */
 348           if (u->mode == WRITING)
 349             {
 350               /* unit_truncate takes care of flushing.  */
 351               unit_truncate (u, stell (u->s), &fpp->common);
 352               /* .. but we still need to reset since we're going to seek.  */
 353               fbuf_reset (u);
 354             }
 355           else
 356             {
 357               /* Make sure buffers are reset.  */
 358               if (u->flags.form == FORM_FORMATTED)
 359                 fbuf_reset (u);
 360               sflush (u->s);
 361             }
 362
 363           u->mode = READING;
 364           u->last_record = 0;
 365
 366           if (sseek (u->s, 0, SEEK_SET) < 0)
 367             generate_error (&fpp->common, LIBERROR_OS, NULL);
 368
 369           /* Handle special files like /dev/null differently.  */
 370           if (!is_special (u->s))
 371             {
 372               /* We are rewinding so we are not at the end.  */
 373               u->endfile = NO_ENDFILE;
 374             }
 375           else
 376             {
 377               /* Set this for compatibilty with g77 for /dev/null.  */
 378               if (file_length (u->s) == 0  && stell (u->s) == 0)
 379                 u->endfile = AT_ENDFILE;
 380               /* Future refinements on special files can go here.  */
 381             }
 382
 383           u->current_record = 0;
 384           u->strm_pos = 1;
 385           u->read_bad = 0;
 386         }
 387       /* Update position for INQUIRE.  */
 388       u->flags.position = POSITION_REWIND;
 389       unlock_unit (u);
 390     }
 391
 392   library_end ();
 393 }
 394
 395
 396 extern void st_flush (st_parameter_filepos *);
 397 export_proto(st_flush);
 398
 399 void
 400 st_flush (st_parameter_filepos *fpp)
 401 {
 402   gfc_unit *u;
 403
 404   library_start (&fpp->common);
 405
 406   u = find_unit (fpp->common.unit);
 407   if (u != NULL)
 408     {
 409       /* Make sure format buffer is flushed.  */
 410       if (u->flags.form == FORM_FORMATTED)
 411         fbuf_flush (u, u->mode);
 412
 413       sflush (u->s);
 414       unlock_unit (u);
 415     }
 416   else
 417     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 418     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 419                         "Specified UNIT in FLUSH is not connected");
 420
 421   library_end ();
 422 }