libgfortran/io/file_pos.c

   1 /* Copyright (C) 2002-2013 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 "fbuf.h"
  27 #include "unix.h"
  28 #include <string.h>
  29
  30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
  31    ENDFILE, and REWIND as well as the FLUSH statement.  */
  32
  33
  34 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
  35    current position is after the newline that terminates the previous
  36    record, and we have to sift backwards to find the newline before
  37    that or the start of the file, whichever comes first.  */
  38
  39 static const int READ_CHUNK = 4096;
  40
  41 static void
  42 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  43 {
  44   gfc_offset base;
  45   char p[READ_CHUNK];
  46   ssize_t n;
  47
  48   base = stell (u->s) - 1;
  49
  50   do
  51     {
  52       n = (base < READ_CHUNK) ? base : READ_CHUNK;
  53       base -= n;
  54       if (sseek (u->s, base, SEEK_SET) < 0)
  55         goto io_error;
  56       if (sread (u->s, p, n) != n)
  57         goto io_error;
  58
  59       /* We have moved backwards from the current position, it should
  60          not be possible to get a short read.  Because it is not
  61          clear what to do about such thing, we ignore the possibility.  */
  62
  63       /* There is no memrchr() in the C library, so we have to do it
  64          ourselves.  */
  65
  66       while (n > 0)
  67         {
  68           n--;
  69           if (p[n] == '\n')
  70             {
  71               base += n + 1;
  72               goto done;
  73             }
  74         }
  75
  76     }
  77   while (base != 0);
  78
  79   /* base is the new pointer.  Seek to it exactly.  */
  80  done:
  81   if (sseek (u->s, base, SEEK_SET) < 0)
  82     goto io_error;
  83   u->last_record--;
  84   u->endfile = NO_ENDFILE;
  85
  86   return;
  87
  88  io_error:
  89   generate_error (&fpp->common, LIBERROR_OS, NULL);
  90 }
  91
  92
  93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
  94    sequential file.  We are guaranteed to be between records on entry and
  95    we have to shift to the previous record.  Loop over subrecords.  */
  96
  97 static void
  98 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
  99 {
 100   gfc_offset m, slen;
 101   GFC_INTEGER_4 m4;
 102   GFC_INTEGER_8 m8;
 103   ssize_t length;
 104   int continued;
 105   char p[sizeof (GFC_INTEGER_8)];
 106
 107   if (compile_options.record_marker == 0)
 108     length = sizeof (GFC_INTEGER_4);
 109   else
 110     length = compile_options.record_marker;
 111
 112   do
 113     {
 114       slen = - (gfc_offset) length;
 115       if (sseek (u->s, slen, SEEK_CUR) < 0)
 116         goto io_error;
 117       if (sread (u->s, p, length) != length)
 118         goto io_error;
 119
 120       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
 121       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
 122         {
 123           switch (length)
 124             {
 125             case sizeof(GFC_INTEGER_4):
 126               memcpy (&m4, p, sizeof (m4));
 127               m = m4;
 128               break;
 129
 130             case sizeof(GFC_INTEGER_8):
 131               memcpy (&m8, p, sizeof (m8));
 132               m = m8;
 133               break;
 134
 135             default:
 136               runtime_error ("Illegal value for record marker");
 137               break;
 138             }
 139         }
 140       else
 141         {
 142           uint32_t u32;
 143           uint64_t u64;
 144           switch (length)
 145             {
 146             case sizeof(GFC_INTEGER_4):
 147               memcpy (&u32, p, sizeof (u32));
 148               u32 = __builtin_bswap32 (u32);
 149               memcpy (&m4, &u32, sizeof (m4));
 150               m = m4;
 151               break;
 152
 153             case sizeof(GFC_INTEGER_8):
 154               memcpy (&u64, p, sizeof (u64));
 155               u64 = __builtin_bswap64 (u64);
 156               memcpy (&m8, &u64, sizeof (m8));
 157               m = m8;
 158               break;
 159
 160             default:
 161               runtime_error ("Illegal value for record marker");
 162               break;
 163             }
 164
 165         }
 166
 167       continued = m < 0;
 168       if (continued)
 169         m = -m;
 170
 171       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 172         goto io_error;
 173     } while (continued);
 174
 175   u->last_record--;
 176   return;
 177
 178  io_error:
 179   generate_error (&fpp->common, LIBERROR_OS, NULL);
 180 }
 181
 182
 183 extern void st_backspace (st_parameter_filepos *);
 184 export_proto(st_backspace);
 185
 186 void
 187 st_backspace (st_parameter_filepos *fpp)
 188 {
 189   gfc_unit *u;
 190
 191   library_start (&fpp->common);
 192
 193   u = find_unit (fpp->common.unit);
 194   if (u == NULL)
 195     {
 196       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
 197       goto done;
 198     }
 199
 200   /* Direct access is prohibited, and so is unformatted stream access.  */
 201
 202
 203   if (u->flags.access == ACCESS_DIRECT)
 204     {
 205       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 206                       "Cannot BACKSPACE a file opened for DIRECT access");
 207       goto done;
 208     }
 209
 210   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
 211     {
 212       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 213                       "Cannot BACKSPACE an unformatted stream file");
 214       goto done;
 215     }
 216
 217   /* Make sure format buffer is flushed and reset.  */
 218   if (u->flags.form == FORM_FORMATTED)
 219     {
 220       int pos = fbuf_reset (u);
 221       if (pos != 0)
 222         sseek (u->s, pos, SEEK_CUR);
 223     }
 224
 225
 226   /* Check for special cases involving the ENDFILE record first.  */
 227
 228   if (u->endfile == AFTER_ENDFILE)
 229     {
 230       u->endfile = AT_ENDFILE;
 231       u->flags.position = POSITION_APPEND;
 232       sflush (u->s);
 233     }
 234   else
 235     {
 236       if (stell (u->s) == 0)
 237         {
 238           u->flags.position = POSITION_REWIND;
 239           goto done;            /* Common special case */
 240         }
 241
 242       if (u->mode == WRITING)
 243         {
 244           /* If there are previously written bytes from a write with
 245              ADVANCE="no", add a record marker before performing the
 246              BACKSPACE.  */
 247
 248           if (u->previous_nonadvancing_write)
 249             finish_last_advance_record (u);
 250
 251           u->previous_nonadvancing_write = 0;
 252
 253           unit_truncate (u, stell (u->s), &fpp->common);
 254           u->mode = READING;
 255         }
 256
 257       if (u->flags.form == FORM_FORMATTED)
 258         formatted_backspace (fpp, u);
 259       else
 260         unformatted_backspace (fpp, u);
 261
 262       u->flags.position = POSITION_UNSPECIFIED;
 263       u->endfile = NO_ENDFILE;
 264       u->current_record = 0;
 265       u->bytes_left = 0;
 266     }
 267
 268  done:
 269   if (u != NULL)
 270     unlock_unit (u);
 271
 272   library_end ();
 273 }
 274
 275
 276 extern void st_endfile (st_parameter_filepos *);
 277 export_proto(st_endfile);
 278
 279 void
 280 st_endfile (st_parameter_filepos *fpp)
 281 {
 282   gfc_unit *u;
 283
 284   library_start (&fpp->common);
 285
 286   u = find_unit (fpp->common.unit);
 287   if (u != NULL)
 288     {
 289       if (u->flags.access == ACCESS_DIRECT)
 290         {
 291           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 292                           "Cannot perform ENDFILE on a file opened "
 293                           "for DIRECT access");
 294           goto done;
 295         }
 296
 297       if (u->flags.access == ACCESS_SEQUENTIAL
 298           && u->endfile == AFTER_ENDFILE)
 299         {
 300           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
 301                           "Cannot perform ENDFILE on a file already "
 302                           "positioned after the EOF marker");
 303           goto done;
 304         }
 305
 306       /* If there are previously written bytes from a write with ADVANCE="no",
 307          add a record marker before performing the ENDFILE.  */
 308
 309       if (u->previous_nonadvancing_write)
 310         finish_last_advance_record (u);
 311
 312       u->previous_nonadvancing_write = 0;
 313
 314       if (u->current_record)
 315         {
 316           st_parameter_dt dtp;
 317           dtp.common = fpp->common;
 318           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
 319           dtp.u.p.current_unit = u;
 320           next_record (&dtp, 1);
 321         }
 322
 323       unit_truncate (u, stell (u->s), &fpp->common);
 324       u->endfile = AFTER_ENDFILE;
 325       if (0 == stell (u->s))
 326         u->flags.position = POSITION_REWIND;
 327     }
 328   else
 329     {
 330       if (fpp->common.unit < 0)
 331         {
 332           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 333                           "Bad unit number in statement");
 334           return;
 335         }
 336
 337       u = find_or_create_unit (fpp->common.unit);
 338       if (u->s == NULL)
 339         {
 340           /* Open the unit with some default flags.  */
 341           st_parameter_open opp;
 342           unit_flags u_flags;
 343
 344           memset (&u_flags, '\0', sizeof (u_flags));
 345           u_flags.access = ACCESS_SEQUENTIAL;
 346           u_flags.action = ACTION_READWRITE;
 347
 348           /* Is it unformatted?  */
 349           if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
 350                                      | IOPARM_DT_IONML_SET)))
 351             u_flags.form = FORM_UNFORMATTED;
 352           else
 353             u_flags.form = FORM_UNSPECIFIED;
 354
 355           u_flags.delim = DELIM_UNSPECIFIED;
 356           u_flags.blank = BLANK_UNSPECIFIED;
 357           u_flags.pad = PAD_UNSPECIFIED;
 358           u_flags.decimal = DECIMAL_UNSPECIFIED;
 359           u_flags.encoding = ENCODING_UNSPECIFIED;
 360           u_flags.async = ASYNC_UNSPECIFIED;
 361           u_flags.round = ROUND_UNSPECIFIED;
 362           u_flags.sign = SIGN_UNSPECIFIED;
 363           u_flags.status = STATUS_UNKNOWN;
 364           u_flags.convert = GFC_CONVERT_NATIVE;
 365
 366           opp.common = fpp->common;
 367           opp.common.flags &= IOPARM_COMMON_MASK;
 368           u = new_unit (&opp, u, &u_flags);
 369           if (u == NULL)
 370             return;
 371           u->endfile = AFTER_ENDFILE;
 372         }
 373     }
 374
 375   done:
 376     unlock_unit (u);
 377
 378   library_end ();
 379 }
 380
 381
 382 extern void st_rewind (st_parameter_filepos *);
 383 export_proto(st_rewind);
 384
 385 void
 386 st_rewind (st_parameter_filepos *fpp)
 387 {
 388   gfc_unit *u;
 389
 390   library_start (&fpp->common);
 391
 392   u = find_unit (fpp->common.unit);
 393   if (u != NULL)
 394     {
 395       if (u->flags.access == ACCESS_DIRECT)
 396         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 397                         "Cannot REWIND a file opened for DIRECT access");
 398       else
 399         {
 400           /* If there are previously written bytes from a write with ADVANCE="no",
 401              add a record marker before performing the ENDFILE.  */
 402
 403           if (u->previous_nonadvancing_write)
 404             finish_last_advance_record (u);
 405
 406           u->previous_nonadvancing_write = 0;
 407
 408           fbuf_reset (u);
 409
 410           u->last_record = 0;
 411
 412           if (sseek (u->s, 0, SEEK_SET) < 0)
 413             generate_error (&fpp->common, LIBERROR_OS, NULL);
 414
 415           /* Set this for compatibilty with g77 for /dev/null.  */
 416           if (ssize (u->s) == 0)
 417             u->endfile = AT_ENDFILE;
 418           else
 419             {
 420               /* We are rewinding so we are not at the end.  */
 421               u->endfile = NO_ENDFILE;
 422             }
 423
 424           u->current_record = 0;
 425           u->strm_pos = 1;
 426           u->read_bad = 0;
 427         }
 428       /* Update position for INQUIRE.  */
 429       u->flags.position = POSITION_REWIND;
 430       unlock_unit (u);
 431     }
 432
 433   library_end ();
 434 }
 435
 436
 437 extern void st_flush (st_parameter_filepos *);
 438 export_proto(st_flush);
 439
 440 void
 441 st_flush (st_parameter_filepos *fpp)
 442 {
 443   gfc_unit *u;
 444
 445   library_start (&fpp->common);
 446
 447   u = find_unit (fpp->common.unit);
 448   if (u != NULL)
 449     {
 450       /* Make sure format buffer is flushed.  */
 451       if (u->flags.form == FORM_FORMATTED)
 452         fbuf_flush (u, u->mode);
 453
 454       sflush (u->s);
 455       unlock_unit (u);
 456     }
 457   else
 458     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
 459     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 460                         "Specified UNIT in FLUSH is not connected");
 461
 462   library_end ();
 463 }